395 lines
16 KiB
Haskell
395 lines
16 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
module Handler.Sheet where
|
|
|
|
import Import
|
|
import System.FilePath (takeFileName)
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Zip
|
|
|
|
-- 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.Monad.Writer (MonadWriter(..), execWriterT)
|
|
|
|
import Network.Mime
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
|
|
instance Eq (Unique Sheet) where
|
|
(CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
|
|
cid1 == cid2 && name1 == name2
|
|
|
|
{-
|
|
* Implement Handlers
|
|
* Implement Breadcrumbs in Foundation
|
|
* Implement Access in Foundation
|
|
-}
|
|
|
|
data SheetForm = SheetForm
|
|
{ sfName :: Text
|
|
, sfDescription :: Maybe Html
|
|
, sfType :: SheetType
|
|
, sfGrouping :: SheetGroup
|
|
, sfMarkingText :: Maybe Html
|
|
, sfVisibleFrom :: Maybe UTCTime
|
|
, sfActiveFrom :: UTCTime
|
|
, sfActiveTo :: UTCTime
|
|
, sfSheetF :: Maybe (Source Handler (Either FileId File))
|
|
, sfHintFrom :: Maybe UTCTime
|
|
, sfHintF :: Maybe FileInfo
|
|
, sfSolutionFrom :: Maybe UTCTime
|
|
, sfSolutionF :: Maybe FileInfo
|
|
-- Keine SheetId im Formular!
|
|
}
|
|
|
|
|
|
makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
|
|
makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
|
let oldFileIds fType
|
|
| Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
|
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
|
|
E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sId
|
|
E.&&. sheetFile E.^. SheetFileType E.==. E.val fType
|
|
return (file E.^. FileId)
|
|
| otherwise = return Set.empty
|
|
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
|
|
<$> areq textField (fsb "Name") (sfName <$> template)
|
|
<*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfDescription <$> template)
|
|
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
|
|
<*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template)
|
|
<*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
|
|
<*> aopt utcTimeField (fsb "Sichtbar ab") (sfVisibleFrom <$> template)
|
|
<*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template)
|
|
<*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template)
|
|
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fsb "Aufgabenstellung") (sfSheetF <$> template)
|
|
<*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template)
|
|
<*> fileAFormOpt (fsb "Hinweis")
|
|
<*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template)
|
|
<*> fileAFormOpt (fsb "Lösung")
|
|
<* submitButton
|
|
return $ case result of
|
|
FormSuccess sheetResult
|
|
| errorMsgs <- validateSheet sheetResult
|
|
, not $ null errorMsgs ->
|
|
(FormFailure errorMsgs,
|
|
[whamlet|
|
|
<div class="alert alert-danger">
|
|
<h4> Fehler:
|
|
<ul>
|
|
$forall errmsg <- errorMsgs
|
|
<li> #{errmsg}
|
|
^{widget}
|
|
|]
|
|
)
|
|
_ -> (result, widget)
|
|
where
|
|
validateSheet :: SheetForm -> [Text]
|
|
validateSheet (SheetForm{..}) =
|
|
[ msg | (False, msg) <-
|
|
[ ( maybe True (sfActiveFrom >=) sfVisibleFrom
|
|
, "Sichtbarkeit muss vor Beginn der Abgabefrist liegen."
|
|
)
|
|
, ( sfActiveTo >= sfActiveFrom
|
|
, "Ende der Abgabefrist muss nach deren Beginn liegen."
|
|
)
|
|
-- TODO: continue validation here!!!
|
|
] ]
|
|
|
|
|
|
fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
|
|
, E.SqlSelect b a
|
|
, Typeable a, MonadHandler m, IsPersistBackend backend
|
|
, PersistQueryRead backend, PersistUniqueRead backend
|
|
)
|
|
=> (E.SqlExpr (Entity Sheet) -> b)
|
|
-> Key Term -> Text -> Text -> ReaderT backend m a
|
|
fetchSheetAux prj tid csh shn =
|
|
let cachId = encodeUtf8 $ tshow (tid,csh,shn)
|
|
in cachedBy cachId $ do
|
|
-- Mit Yesod:
|
|
-- cid <- getKeyBy404 $ CourseTermShort tid csh
|
|
-- getBy404 $ CourseSheet cid shn
|
|
-- Mit Esqueleto:
|
|
sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
|
|
E.where_ $ course E.^. CourseTermId E.==. E.val tid
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. sheet E.^. SheetName E.==. E.val shn
|
|
return $ prj sheet
|
|
case sheetList of
|
|
[sheet] -> return sheet
|
|
_other -> notFound
|
|
|
|
fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
|
|
fetchSheet = fetchSheetAux id
|
|
|
|
fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet)
|
|
fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
|
|
|
|
-- List Sheets
|
|
getSheetListCID :: CourseId -> Handler Html
|
|
getSheetListCID cid = getSheetList =<<
|
|
(Entity cid) <$> (runDB $ get404 cid)
|
|
|
|
getSheetListR :: TermId -> Text -> Handler Html
|
|
getSheetListR tid csh = getSheetList =<<
|
|
(runDB $ getBy404 $ CourseTermShort tid csh)
|
|
|
|
getSheetList :: Entity Course -> Handler Html
|
|
getSheetList courseEnt = do
|
|
-- mbAid <- maybeAuthId
|
|
let cid = entityKey courseEnt
|
|
let course = entityVal courseEnt
|
|
let csh = courseShorthand course
|
|
let tid = courseTermId course
|
|
sheets <- runDB $ do
|
|
rawSheets <- selectList [SheetCourseId ==. cid] [Desc SheetActiveFrom]
|
|
forM rawSheets $ \(Entity sid sheet) -> do
|
|
let sheetsub = [SubmissionSheetId ==. sid]
|
|
submissions <- count sheetsub
|
|
rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
|
|
return (sid, sheet, (submissions, rated))
|
|
let colBase = mconcat
|
|
[ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ sheetName sheet
|
|
, headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
|
|
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
|
|
, headed "Bewertung" $ toWgt . show . sheetType . snd3
|
|
]
|
|
let colAdmin = mconcat -- only show edit button for allowed course assistants
|
|
[ headed "Korrigiert" $ toWgt . snd . trd3
|
|
, headed "Eingereicht" $ toWgt . fst . trd3
|
|
, headed "" $ \s -> linkButton "Edit" BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s
|
|
, headed "" $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR $ sheetName $ snd3 s
|
|
]
|
|
showAdmin <- case sheets of
|
|
((_,firstSheet,_):_) -> do
|
|
setUltDestCurrent
|
|
(Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False
|
|
_otherwise -> return False
|
|
let colSheets = if showAdmin
|
|
then colBase `mappend` colAdmin
|
|
else colBase
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ T.append "Übungsblätter " csh
|
|
if null sheets
|
|
then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
|
|
else encodeWidgetTable tableDefault colSheets sheets
|
|
|
|
-- Show single sheet
|
|
getSheetShowR :: TermId -> Text -> Text -> Handler Html
|
|
getSheetShowR tid csh shn = do
|
|
entSheet <- runDB $ fetchSheet tid csh shn
|
|
let sheet = entityVal entSheet
|
|
sid = entityKey entSheet
|
|
--
|
|
fileNameTypes <- runDB $ E.select $ E.from $
|
|
\(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
|
-- Restrict to consistent rows that correspond to each other
|
|
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFileId)
|
|
E.on (sheetFile E.^. SheetFileSheetId E.==. sheet E.^. SheetId)
|
|
-- filter to requested file
|
|
E.where_ (sheet E.^. SheetId E.==. E.val sid )
|
|
-- return desired columns
|
|
return $ (file E.^. FileTitle, sheetFile E.^. SheetFileType)
|
|
let fileLinks = map (\(E.Value fName, E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName)) fileNameTypes
|
|
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
|
|
$(widgetFile "sheetShow")
|
|
[whamlet| Under Construction !!! |] -- TODO
|
|
|
|
|
|
getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
|
|
getSheetFileR tid csh shn typ title = do
|
|
content <- runDB $ E.select $ E.from $
|
|
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
|
-- Restrict to consistent rows that correspond to each other
|
|
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFileId)
|
|
E.on (sheetFile E.^. SheetFileSheetId E.==. sheet E.^. SheetId)
|
|
E.on (sheet E.^. SheetCourseId E.==. course E.^. CourseId)
|
|
-- filter to requested file
|
|
E.where_ ((file E.^. FileTitle E.==. E.val title)
|
|
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
|
|
E.&&. (sheet E.^. SheetName E.==. E.val shn )
|
|
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
|
|
E.&&. (course E.^. CourseTermId E.==. E.val tid )
|
|
)
|
|
-- return desired columns
|
|
return $ file E.^. FileContent
|
|
let mimeType = defaultMimeLookup $ pack title
|
|
case content of
|
|
[E.Value (Just nochmalContent)] -> do
|
|
addHeader "Content-Disposition" "attachment"
|
|
respond mimeType nochmalContent
|
|
[] -> notFound
|
|
_other -> error "Multiple matching files found."
|
|
|
|
|
|
getSheetNewR :: TermId -> Text -> Handler Html
|
|
getSheetNewR tid csh = do
|
|
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
|
|
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
|
|
insertUnique $ newSheet
|
|
handleSheetEdit tid csh Nothing template action
|
|
|
|
postSheetNewR :: TermId -> Text -> Handler Html
|
|
postSheetNewR = getSheetNewR
|
|
|
|
|
|
getSheetEditR :: TermId -> Text -> Text -> Handler Html
|
|
getSheetEditR tid csh shn = do
|
|
(sheetEnt, sheetFileIds) <- runDB $ do
|
|
ent <- fetchSheet tid csh shn
|
|
fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
|
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
|
|
E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val (entityKey ent)
|
|
E.&&. sheetFile E.^. SheetFileType E.==. E.val SheetExercise
|
|
return (file E.^. FileId)
|
|
return (ent, fIds)
|
|
let sid = entityKey sheetEnt
|
|
let oldSheet@(Sheet {..}) = entityVal sheetEnt
|
|
let template = Just $ SheetForm
|
|
{ sfName = sheetName
|
|
, sfDescription = sheetDescription
|
|
, sfType = sheetType
|
|
, sfGrouping = sheetGrouping
|
|
, sfMarkingText = sheetMarkingText
|
|
, sfVisibleFrom = sheetVisibleFrom
|
|
, sfActiveFrom = sheetActiveFrom
|
|
, sfActiveTo = sheetActiveTo
|
|
, sfSheetF = Just . yieldMany . map Left $ Set.toList sheetFileIds
|
|
, sfHintFrom = sheetHintFrom
|
|
, sfHintF = Nothing -- TODO
|
|
, sfSolutionFrom = sheetSolutionFrom
|
|
, sfSolutionF = Nothing -- TODO
|
|
}
|
|
let action newSheet = do
|
|
replaceRes <- myReplaceUnique sid $ newSheet
|
|
case replaceRes of
|
|
Nothing -> return $ Just sid
|
|
(Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
|
|
handleSheetEdit tid csh (Just sid) template action
|
|
|
|
postSheetEditR :: TermId -> Text -> Text -> Handler Html
|
|
postSheetEditR = getSheetEditR
|
|
|
|
handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
|
|
handleSheetEdit tid csh msId template dbAction = do
|
|
let tident = unTermKey tid
|
|
let mbshn = sfName <$> template
|
|
aid <- requireAuthId
|
|
((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
|
|
case res of
|
|
(FormSuccess SheetForm{..}) -> do
|
|
saveOkay <- runDB $ do
|
|
actTime <- liftIO getCurrentTime
|
|
cid <- getKeyBy404 $ CourseTermShort tid csh
|
|
let newSheet = Sheet
|
|
{ sheetCourseId = cid
|
|
, sheetName = sfName
|
|
, sheetDescription = sfDescription
|
|
, sheetType = sfType
|
|
, sheetGrouping = sfGrouping
|
|
, sheetMarkingText = sfMarkingText
|
|
, sheetVisibleFrom = sfVisibleFrom
|
|
, sheetActiveFrom = sfActiveFrom
|
|
, sheetActiveTo = sfActiveTo
|
|
, sheetHintFrom = sfHintFrom
|
|
, sheetSolutionFrom = sfSolutionFrom
|
|
}
|
|
mbsid <- dbAction newSheet
|
|
case mbsid of
|
|
Nothing -> False <$ addMessageI "danger" (MsgSheetNameDup tident csh sfName)
|
|
(Just sid) -> do -- save files in DB:
|
|
whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise
|
|
whenIsJust sfHintF $ insertSheetFile sid SheetHint
|
|
whenIsJust sfSolutionF $ insertSheetFile sid SheetSolution
|
|
insert_ $ SheetEdit aid actTime sid
|
|
addMessageI "info" $ MsgSheetEditOk tident csh sfName
|
|
return True
|
|
when saveOkay $ redirect $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB
|
|
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
|
_ -> return ()
|
|
let pageTitle = maybe (MsgSheetTitleNew tident csh)
|
|
(MsgSheetTitle tident csh) mbshn
|
|
let formTitle = pageTitle
|
|
let formText = Nothing :: Maybe UniWorXMessage
|
|
actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute
|
|
defaultLayout $ do
|
|
setTitleI pageTitle
|
|
$(widgetFile "formPageI18n")
|
|
|
|
|
|
|
|
getSheetDelR :: TermId -> Text -> Text -> Handler Html
|
|
getSheetDelR tid csh shn = do
|
|
let tident = unTermKey tid
|
|
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
|
|
case result of
|
|
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn
|
|
(FormSuccess BtnDelete) -> do
|
|
runDB $ fetchSheetId tid csh shn >>= deleteCascade
|
|
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
|
|
setMessageI $ MsgSheetDelOk tident csh shn
|
|
redirect $ CSheetR tid csh SheetListR
|
|
_other -> do
|
|
submissionno <- runDB $ do
|
|
sid <- fetchSheetId tid csh shn
|
|
count [SubmissionSheetId ==. sid]
|
|
let formTitle = MsgSheetDelTitle tident csh shn
|
|
let formText = Just $ MsgSheetDelText submissionno
|
|
let actionUrl = CSheetR tid csh $ SheetDelR shn
|
|
defaultLayout $ do
|
|
setTitleI $ MsgSheetTitle tident csh shn
|
|
$(widgetFile "formPageI18n")
|
|
|
|
postSheetDelR :: TermId -> Text -> Text -> Handler Html
|
|
postSheetDelR = getSheetDelR
|
|
|
|
|
|
|
|
insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
|
|
insertSheetFile sid ftype finfo = do
|
|
runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert
|
|
where
|
|
finsert file = do
|
|
fid <- insert file
|
|
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
|
|
|
|
insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
|
|
insertSheetFile' sid ftype fs = do
|
|
oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
|
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
|
|
E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sid
|
|
E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype
|
|
return (file E.^. FileId)
|
|
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
|
|
mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
|
|
where
|
|
finsert (Left fileId) = tell $ singleton fileId
|
|
finsert (Right file) = lift $ do
|
|
fid <- insert file
|
|
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
|