Submission upload (Sitzung mit Gregor)

messages/de.msg

@@ -23,4 +23,6 @@ UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut
 UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
 UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
 UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
-OnlyUploadOneFile: Bitte nur eine Datei hochladen.
+OnlyUploadOneFile: Bitte nur eine Datei hochladen.
+SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
+SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}: Abgabe

routes

@@ -20,17 +20,20 @@
   /edit                       CourseEditR GET POST            !lecturer
 
   /ex SheetR                                                  !registered:
-    /                               SheetListR GET
+    /                                SheetListR GET
-    /#Text/show                     SheetShowR GET            !time
+    /#Text/show                      SheetShowR GET            !time
-    /#Text/#SheetFileType/#FilePath SheetFileR GET            !time
+    /#Text/#SheetFileType/#FilePath  SheetFileR GET            !time
-    /new                            SheetNewR  GET POST       !lecturer
+    /new                             SheetNewR  GET POST       !lecturer
-    /#Text/edit                     SheetEditR GET POST       !lecturer
+    /#Text/edit                      SheetEditR GET POST       !lecturer
-    /#Text/delete                   SheetDelR  GET POST       !lecturer
+    /#Text/delete                    SheetDelR  GET POST       !lecturer
+    !/#Text/submission/#SubmissionMode SubmissionR GET POST    !time
+
+
 
 
 -- TODO below
 /submission                 SubmissionListR GET POST
-/submission/#CryptoUUIDSubmission SubmissionR GET POST
+/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST
 /submissions.zip SubmissionDownloadMultiArchiveR POST
 !/submission/archive/#FilePath SubmissionDownloadArchiveR GET
 !/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET

src/CryptoID.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -37,3 +38,16 @@ decCryptoIDs [ ''SubmissionId
              , ''FileId
              ]
 {- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
+
+
+
+newtype SubmissionMode = SubmissionMode (Maybe CryptoUUIDSubmission)
+  deriving (Show, Read, Eq)
+
+instance PathPiece SubmissionMode where
+    fromPathPiece "new" = Just $ SubmissionMode Nothing
+    fromPathPiece s     = SubmissionMode . Just <$> fromPathPiece s
+
+    toPathPiece (SubmissionMode Nothing)  = "new"
+    toPathPiece (SubmissionMode (Just x)) = toPathPiece x
+

src/Foundation.hs

@@ -244,7 +244,7 @@ isAuthorizedDB route@(routeAttrs -> attrs) writeable
 
 
 isAuthorizedDB UsersR _ = adminAccess Nothing
-isAuthorizedDB (SubmissionR cID)       _ = submissionAccess $ Right cID
+isAuthorizedDB (SubmissionDemoR cID)       _ =  return Authorized -- submissionAccess $ Right cID
 isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID
 isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName
 isAuthorizedDB TermEditR               _ = adminAccess Nothing
@@ -254,10 +254,11 @@ isAuthorizedDB (CourseR t c CourseEditR)       _ = courseLecturerAccess . entity
 isAuthorizedDB (CourseR t c (SheetR SheetListR))  False  = return Authorized --
 isAuthorizedDB (CourseR t c (SheetR SheetListR)) _       = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
 isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _   = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
-isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
+isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _)))  _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
-isAuthorizedDB (CourseR t c (SheetR SheetNewR))          _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (CourseR t c (SheetR SheetNewR))           _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (CourseR t c (SheetR (SheetEditR s)))     _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (CourseR t c (SheetR (SheetEditR s)))      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (CourseR t c (SheetR (SheetDelR  s)))     _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (CourseR t c (SheetR (SheetDelR  s)))      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (CourseR t c (SheetR (SubmissionR s m)))   _ = return Authorized -- TODO -- submissionAccess $ Right cID
 isAuthorizedDB (CourseEditIDR cID)     _ = do
   courseId <- decrypt cID
   courseLecturerAccess courseId
@@ -339,9 +340,10 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn,      Just $ CourseR tid csh $ SheetR SheetListR)
   breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit",   Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
   breadcrumb (CourseR tid csh (SheetR (SheetDelR  shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
+  breadcrumb (CourseR tid csh (SheetR (SubmissionR shn _))) = return ("Abgabe", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
 
   breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
-  breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR)
+
 
   breadcrumb HomeR = return ("UniworkY", Nothing)
   breadcrumb (AuthR _) = return ("Login", Just HomeR)

src/Handler/CryptoIDDispatch.hs

@@ -20,6 +20,8 @@ import Import hiding (Proxy)
 
 import Data.Proxy
 
+import Handler.Utils
+
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
 import qualified Control.Monad.Catch as E (Handler(..))
@@ -30,9 +32,13 @@ class CryptoRoute ciphertext plaintext where
 
 instance CryptoRoute UUID SubmissionId where
   cryptoIDRoute _ (CryptoID -> cID) = do
-    (_ :: SubmissionId) <- decrypt cID
+    (smid :: SubmissionId) <- decrypt cID
-    
+    (tid,csh,shn) <- runDB $ do
-    return $ SubmissionR cID
+      shid <- submissionSheetId <$> get404 smid
+      Sheet{..}  <- get404 shid
+      Course{..} <- get404 sheetCourseId
+      return (courseTermId, courseShorthand, sheetName)
+    return $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
 
 
 class Dispatch ciphertext (x :: [*]) where

src/Handler/Sheet.hs

@@ -118,35 +118,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       ] ]
 
 
-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
@@ -205,6 +177,7 @@ getSheetList courseEnt = do
       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
@@ -228,7 +201,6 @@ getSheetShowR tid csh shn = do
     $(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 $

src/Handler/Submission.hs

@@ -24,6 +24,7 @@ import Control.Monad.Trans.Maybe
 import Control.Monad.State.Class
 import Control.Monad.Trans.State.Strict (StateT)
 
+import qualified Data.Maybe
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Data.CaseInsensitive as CI
@@ -42,6 +43,55 @@ import Colonnade
 import Yesod.Colonnade
 import qualified Text.Blaze.Html5.Attributes as HA
 
+
+
+makeSubmissionForm :: Bool -> Form (Source Handler File)
+makeSubmissionForm unpackZips = identForm FIDsubmission $ \html -> do
+    flip (renderAForm FormStandard) html $
+      areq (zipFileField unpackZips) "Zip Archiv zur Abgabe" Nothing
+      <*  submitButton
+
+getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> SubmissionMode -> Handler Html
+getSubmissionR = postSubmissionR
+postSubmissionR tid csh shn (SubmissionMode mcid) = do
+  uid   <- requireAuthId
+  msmid <- traverse decrypt mcid
+  shid   <- runDB $ do
+    shid  <- fetchSheetId tid csh shn
+    case msmid of
+      Nothing     -> return shid
+      (Just smid) -> do
+        shid' <- submissionSheetId <$> get404 smid
+        when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
+        return shid
+  let unpackZips = True -- undefined -- TODO
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips
+  case res of
+    (FormSuccess files) -> do
+      smid <- runDB $ runConduit $
+        transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid)
+      cID <- encrypt smid
+      redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
+    (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
+    _other -> return ()
+
+  let pageTitle = MsgSubmissionTitle (unTermKey tid) csh shn
+  let formTitle = pageTitle
+  let formText  = Nothing :: Maybe UniWorXMessage
+  actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
+  defaultLayout $ do
+    setTitleI pageTitle
+    $(widgetFile "formPageI18n")
+
+
+
+
+
+
+
+------------------------- DEMO BELOW
+
+
 submissionTable :: MForm Handler (FormResult [SubmissionId], Widget)
 submissionTable = do
   subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do
@@ -56,7 +106,7 @@ submissionTable = do
   let
     anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTermId courseShorthand CourseShowR
     courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
-    anchorSubmission (_, cUUID, _) = SubmissionR cUUID
+    anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
     submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
     colonnade = mconcat
       [ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText
@@ -211,9 +261,11 @@ getSubmissionDownloadArchiveR path = do
             info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
         fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder
 
-getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html
+
-getSubmissionR = postSubmissionR
+
-postSubmissionR cID = do
+getSubmissionDemoR, postSubmissionDemoR :: CryptoUUIDSubmission -> Handler Html
+getSubmissionDemoR = postSubmissionDemoR
+postSubmissionDemoR cID = do
   submissionId <- decrypt cID
   
   ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)

src/Handler/Utils.hs

@@ -16,7 +16,8 @@ import Handler.Utils.Form as Handler.Utils
 import Handler.Utils.Table as Handler.Utils
 import Handler.Utils.Table.Pagination as Handler.Utils
 
-import Handler.Utils.Zip as Handler.Utils
+import Handler.Utils.Zip        as Handler.Utils
-import Handler.Utils.Rating as Handler.Utils
+import Handler.Utils.Rating     as Handler.Utils
 import Handler.Utils.Submission as Handler.Utils
-import Handler.Utils.Templates as Handler.Utils
+import Handler.Utils.Sheet      as Handler.Utils
+import Handler.Utils.Templates  as Handler.Utils

src/Handler/Utils/Form.hs

@@ -44,7 +44,7 @@ import qualified Data.Set as Set
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
 
-data FormIdentifier = FIDcourse | FIDsheet
+data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
 

src/Model/Types.hs

@@ -158,3 +158,6 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
 data StudyFieldType = FieldPrimary | FieldSecondary
   deriving (Eq, Ord, Enum, Show, Read, Bounded)
 derivePersistField "StudyFieldType"
+
+
+

templates/submission.hamlet

@@ -33,7 +33,7 @@
       <div .panel .panel-default>
         <div .panel-heading>
           Abgabe ersetzen
-        <form role=form method=post action=@{SubmissionR cID} enctype=#{uploadEnctype} .panel-body>
+        <form role=form method=post action=@{SubmissionDemoR cID} enctype=#{uploadEnctype} .panel-body>
           ^{uploadWidget}
 
 <div .panel .panel-default>