253 lines
9.4 KiB
Haskell
253 lines
9.4 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
module Handler.Sheet where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Utils.Zip
|
|
|
|
|
|
-- import Data.Time
|
|
import qualified Data.Text as T
|
|
-- import Data.Function ((&))
|
|
--
|
|
import Colonnade -- hiding (fromMaybe)
|
|
import Yesod.Colonnade
|
|
--
|
|
import qualified Data.UUID.Cryptographic as UUID
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Network.Mime
|
|
|
|
{-
|
|
* Implement Handlers
|
|
* Implement Breadcrumbs in Foundation
|
|
* Implement Access in Foundation
|
|
-}
|
|
|
|
data SheetForm = SheetForm
|
|
{ sfName :: Text
|
|
, sfComment :: Maybe Html
|
|
, sfType :: SheetType
|
|
, sfMarkingText :: Maybe Html
|
|
, sfActiveFrom :: UTCTime
|
|
, sfActiveTo :: UTCTime
|
|
, sfSheetF :: Maybe FileInfo
|
|
, sfHintFrom :: Maybe UTCTime
|
|
, sfHintF :: Maybe FileInfo
|
|
, sfSolutionFrom :: Maybe UTCTime
|
|
, sfSolutionF :: Maybe FileInfo
|
|
}
|
|
|
|
|
|
makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm
|
|
makeSheetForm cid template = identForm FIDsheet $ \html -> do
|
|
-- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :(
|
|
-- Erstmal nur mit ZIP arbeiten
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
|
|
<$> areq textField (fsb "Name") (sfName <$> template)
|
|
<*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfMarkingText <$> template)
|
|
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
|
|
--TODO: SICHTBARKEIT hinzunehmen
|
|
<*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
|
|
<*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template)
|
|
<*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template)
|
|
<*> fileAFormOpt (fsb "Aufgaben")
|
|
<*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template)
|
|
<*> fileAFormOpt (fsb "Hinweis")
|
|
<*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template)
|
|
<*> fileAFormOpt (fsb "Lösung")
|
|
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 _ = [] -- TODO
|
|
|
|
|
|
fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
|
|
fetchSheet tid csh shn = do
|
|
-- TODO: More efficient with Esquleto?
|
|
(Entity cid _course) <- getBy404 $ CourseTermShort tid csh
|
|
getBy404 $ CourseSheet 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 colSheets = mconcat
|
|
[ headed "Blatt" $ toWgt . sheetName . snd3
|
|
, headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
|
|
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
|
|
, headed "Bewertung" $ toWgt . show . sheetType . snd3
|
|
, headed "Korrigiert" $ toWgt . snd . trd3
|
|
, headed "Eingereicht" $ toWgt . fst . trd3
|
|
-- TODO: only show edit button for allowed course assistants
|
|
, headed "" $ \s -> linkButton "Edit" BCLink $ SheetEditR tid csh $ fst3 s
|
|
]
|
|
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 = getSheetShow =<<
|
|
(runDB $ fetchSheet tid csh shn)
|
|
|
|
{- Nur per UUID
|
|
getSheetIdShowR :: SheetId -> Handler Html
|
|
getSheetIdShowR sheetId = getSheetShow =<<
|
|
(Entity sheetId) <$> (runDB $ get404 sheetId)\
|
|
-}{-
|
|
getSheetUUIDShowR :: CryptoUUIDSheet -> Handler Html
|
|
getSheetUUIDShowR sUUID = do
|
|
cIDKey <- getsYesod appCryptoIDKey
|
|
sheetId <- UUID.decrypt cIDKey sUUID
|
|
sheetEnt <- runDB $ get404 sheetId
|
|
getSheetShow $ Entity sheetId sheetEnt
|
|
-}
|
|
|
|
getSheetShow :: (Entity Sheet) -> Handler Html
|
|
getSheetShow entSheet = do
|
|
let sheet = entityVal entSheet
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
|
|
[whamlet| Under Construction !!! |] -- TODO
|
|
$(widgetFile "sheetAdmin")
|
|
|
|
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
|
|
(Entity cid course) <- runDB $ getBy404 $ CourseTermShort tid csh
|
|
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
|
|
((res,wdgt), enc) <- runFormPost $ makeSheetForm cid template
|
|
|
|
case res of
|
|
(FormSuccess SheetForm{..}) -> do
|
|
|
|
|
|
let sid = undefined -- TODO after first insert
|
|
let sname = undefined -- TODO after first insert
|
|
|
|
-- Prüfe, das FileTitle innerhalb des Sheets eindeutig ist für diesen SheetFileTpye
|
|
whenIsJust sfSheetF $ \sinfo -> do
|
|
let sheetInsert file = do
|
|
fid <- insert file
|
|
void . insert $ SheetFile sid fid SheetExercise
|
|
runDB . runConduit $ (sourceFiles sinfo) =$= C.mapM_ sheetInsert
|
|
|
|
|
|
|
|
addMessage "info" "Blatt angelegt"
|
|
redirect $ SheetShowR tid csh sname
|
|
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
|
_ -> return ()
|
|
defaultLayout $ do
|
|
$(widgetFile "newSheet")
|
|
|
|
postSheetNewR :: TermId -> Text -> Handler Html
|
|
postSheetNewR = getSheetNewR
|
|
|
|
getSheetEditR :: TermId -> Text -> SheetId -> Handler Html
|
|
getSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
|
|
|
postSheetEditR :: TermId -> Text -> SheetId -> Handler Html
|
|
postSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
|
|
|
|
|
getSheetDelR :: TermId -> Text -> SheetId -> Handler Html
|
|
getSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
|
-- Sicherheitsabfrage
|
|
|
|
postSheetDelR :: TermId -> Text -> SheetId -> Handler Html
|
|
postSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
|
-- Tatsächlich löschen
|
|
|
|
|
|
{-
|
|
getCourseShowR :: TermId -> Text -> Handler Html
|
|
getCourseShowR tid csh = do
|
|
mbAid <- maybeAuthId
|
|
(courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
|
|
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh
|
|
dependent <- (,,)
|
|
<$> get (courseSchoolId course) -- join
|
|
<*> count [CourseParticipantCourseId ==. cid] -- join
|
|
<*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
|
|
Nothing -> return False
|
|
(Just aid) -> do
|
|
regL <- getBy (UniqueCourseParticipant cid aid)
|
|
return $ isJust regL)
|
|
return $ (courseEnt,dependent)
|
|
let course = entityVal courseEnt
|
|
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered
|
|
defaultLayout $ do
|
|
setTitle $ [shamlet| #{termToText tid} - #{csh}|]
|
|
$(widgetFile "course")
|
|
-}
|