Merge branch 'master' into feat/exercises

messages/de.msg

@@ -32,8 +32,8 @@ SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht w
 SheetDelOk         tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
 
 Unauthorized: Sie haben hierfür keine explizite Berechtigung.
-UnauthorizedAnd l@Text r@Text: "#{l}" und "#{r}"
+UnauthorizedAnd l@Text r@Text: #{l} UND #{r}
-UnauthorizedOr  l@Text r@Text: "#{l}" oder "#{r}"
+UnauthorizedOr  l@Text r@Text: #{l} ODER #{r}
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
 UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
 UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
@@ -56,7 +56,7 @@ SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termTo
 SubmissionMember g@Int: Mitabgebende(r) ##{tshow g}
 SubmissionArchive: Zip-Archiv der Abgabedatei(en)
 SubmissionFile: Datei zur Abgabe
-SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem Übungsblatt.
+SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem bÜbungsblatt.
 
 CorrectionsTitle: Zugewiesene Korrekturen
 

routes

@@ -50,21 +50,23 @@
   !/ex/new                    SheetNewR       GET POST
   /ex/#Text SheetR:
     /show                       SShowR        GET             !timeANDregistered !timeANDmaterials !corrector
-    /#SheetFileType/#FilePath   SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
+    !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
     /edit                       SEditR        GET POST
     /delete                     SDelR         GET POST
     !/sub/new                   SubmissionNewR GET POST        !timeANDregistered
     !/sub/own                   SubmissionOwnR GET             !free
-    !/sub/#CryptoUUIDSubmission SubmissionR    GET POST        !owner !corrector
+    !/sub/#CryptoFileNameSubmission SubmissionR    GET POST        !owner !corrector
 
 /corrections  CorrectionsR GET !free
 
-!/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect
-
 -- TODO below
 !/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated
-!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET !deprecated
+!/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !deprecated
 
 /submission                 SubmissionListR GET                 !deprecated
 /submission/#CryptoUUIDSubmission SubmissionDemoR GET POST      !deprecated
 /submissions.zip SubmissionDownloadMultiArchiveR POST           !deprecated
+-- TODO above
+
+!/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect
+!/*{CI FilePath} CryptoFileNameDispatchR GET                  !free

src/CryptoID.hs

@@ -24,6 +24,8 @@ import Data.CryptoID.Poly.ImplicitNamespace
 import Data.UUID.Cryptographic.ImplicitNamespace
 import System.FilePath.Cryptographic.ImplicitNamespace
 
+import qualified Data.Text as Text
+
 import Data.UUID.Types
 import Web.PathPieces
 
@@ -35,24 +37,33 @@ instance PathPiece UUID where
   fromPathPiece = fromString . unpack
   toPathPiece = pack . toString
 
+instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
+  fromPathPiece = fmap CI.mk . fromPathPiece
+  toPathPiece = toPathPiece . CI.original
 
--- Generates CryptoUUID... Datatypes
+instance {-# OVERLAPS #-} PathMultiPiece FilePath where
+  fromPathMultiPiece = Just . unpack . intercalate "/"
+  toPathMultiPiece = Text.splitOn "/" . pack
+  
+instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
+  fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
+  toPathMultiPiece = toPathMultiPiece . CI.original
+
+
+-- Generates CryptoUUID... and CryptoFileName... Datatypes
 decCryptoIDs [ ''SubmissionId
-             , ''CourseId
-             , ''SheetId
              , ''FileId
-             , ''UserId
              ]
 {- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
 
 
 
-newtype SubmissionMode = SubmissionMode (Maybe CryptoUUIDSubmission)
+newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)
   deriving (Show, Read, Eq)
 
 pattern NewSubmission :: SubmissionMode
 pattern NewSubmission = SubmissionMode Nothing
-pattern ExistingSubmission :: CryptoUUIDSubmission -> SubmissionMode
+pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode
 pattern ExistingSubmission cID = SubmissionMode (Just cID)
 
 instance PathPiece SubmissionMode where
@@ -62,6 +73,7 @@ instance PathPiece SubmissionMode where
     toPathPiece (SubmissionMode Nothing)  = "new"
     toPathPiece (SubmissionMode (Just x)) = toPathPiece x
 
+
 newtype ZIPArchiveName objID = ZIPArchiveName (CryptoID (CI FilePath) objID)
   deriving (Show, Read, Eq)
 

src/Foundation.hs

@@ -282,13 +282,14 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
          Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
          Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
          cTime <- liftIO getCurrentTime
+         let started = sheetActiveFrom <= cTime  ||  NTop sheetVisibleFrom <= (NTop $ Just cTime)
          case subRoute of
-           SFileR SheetExercise _ -> guard $ maybe False (<= cTime) sheetVisibleFrom
+           SFileR SheetExercise _ -> guard started
            SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
            SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
            SFileR SheetMarking  _ -> mzero -- only for correctors and lecturers
-           SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
+           SubmissionNewR         -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
-           _ -> guard $ maybe False (<= cTime) sheetVisibleFrom
+           _ -> guard started
          return Authorized
        r -> do
          $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r

src/Handler/Course.hs

@@ -142,12 +142,6 @@ postCEditR tid csh = do
   course <- runDB $ getBy $ CourseTermShort tid csh
   courseEditHandler False course
 
-getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
-getCourseEditIDR cID = do
-  cIDKey <- getsYesod appCryptoIDKey
-  courseID <- UUID.decrypt cIDKey cID
-  courseEditHandler True =<< runDB (getEntity courseID)
-
 
 courseDeleteHandler :: Handler Html -- not called anywhere yet
 courseDeleteHandler = undefined

src/Handler/CryptoIDDispatch.hs

@@ -14,6 +14,7 @@
 
 module Handler.CryptoIDDispatch
   ( getCryptoUUIDDispatchR
+  , getCryptoFileNameDispatchR
   ) where
 
 import Import hiding (Proxy)
@@ -26,11 +27,25 @@ import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
 import qualified Control.Monad.Catch as E (Handler(..))
 
+import           Data.CaseInsensitive   (CI)
+import qualified Data.CaseInsensitive as CI
+
 
 class CryptoRoute ciphertext plaintext where
   cryptoIDRoute :: p plaintext -> ciphertext -> Handler (Route UniWorX)
 
 instance CryptoRoute UUID SubmissionId where
+  cryptoIDRoute _ (CryptoID -> cID) = do
+    (smid :: SubmissionId) <- decrypt cID
+    cID' <- encrypt smid
+    (tid,csh,shn) <- runDB $ do
+      shid <- submissionSheet <$> get404 smid
+      Sheet{..}  <- get404 shid
+      Course{..} <- get404 sheetCourse
+      return (courseTerm, courseShorthand, sheetName)
+    return $ CSheetR tid csh shn $ SubmissionR cID'
+
+instance CryptoRoute (CI FilePath) SubmissionId where
   cryptoIDRoute _ (CryptoID -> cID) = do
     (smid :: SubmissionId) <- decrypt cID
     (tid,csh,shn) <- runDB $ do
@@ -66,3 +81,9 @@ getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith
     p :: Proxy '[ SubmissionId
                 ]
     p = Proxy
+
+getCryptoFileNameDispatchR :: CI FilePath -> Handler ()
+getCryptoFileNameDispatchR path = dispatchID p path >>= maybe notFound (redirectWith found302)
+  where
+    p :: Proxy '[ SubmissionId ] 
+    p = Proxy

src/Handler/Sheet.hs

@@ -160,7 +160,7 @@ getSheetList courseEnt = do
         [ headed "Blatt"       $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR
         , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
         , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
-        , headed "Bewertung"   $ toWgt . show . sheetType . snd3
+        , headed "Bewertung"   $ toWgt . display . sheetType . snd3
         ]
   let colAdmin = mconcat -- only show edit button for allowed course assistants
         [ headed "Korrigiert"  $ toWgt . snd . trd3

src/Handler/Submission.hs

@@ -61,7 +61,7 @@ makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [Text] -> Form
 makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
     flip (renderAForm FormStandard) html $ (,)
       <$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
-      <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies textField (fsm $ MsgSubmissionMember g) buddy
+      <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies textField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
                                     | g <- [1..(max groupNr $ length buddies)]             -- groupNr might have decreased meanwhile
                                     | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
                                     ])
@@ -79,7 +79,7 @@ getSubmissionNewR = postSubmissionNewR
 postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission
 
 
-getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoUUIDSubmission -> Handler Html
+getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html
 getSubmissionR = postSubmissionR
 postSubmissionR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
 
@@ -289,16 +289,15 @@ submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.a
   E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]  -- E.desc returns corrector updated data first
   return f
 
-getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
+getSubmissionDownloadSingleR :: CryptoFileNameSubmission -> FilePath -> Handler TypedContent
 getSubmissionDownloadSingleR cID path = do
   submissionID <- decrypt cID
-  cID' <- encrypt submissionID
 
   runDB $ do
     isRating <- maybe False (== submissionID) <$> isRatingFile path
     case isRating of
       True  -> do
-        file <- runMaybeT $ lift . ratingFile cID' =<< MaybeT (getRating submissionID)
+        file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
         maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
       False -> do
         results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do

src/Handler/Utils/Form.hs

@@ -385,8 +385,8 @@ fsb :: Text -> FieldSettings site -- DEPRECATED
 fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
 
 fsl ::  Text -> FieldSettings UniWorX
-fsl label =
+fsl lbl =
-  FieldSettings { fsLabel    = (SomeMessage label)
+  FieldSettings { fsLabel    = (SomeMessage lbl)
                 , fsTooltip  = Nothing
                 , fsId       = Nothing
                 , fsName     = Nothing
@@ -394,8 +394,8 @@ fsl label =
   }
 
 fslp ::  Text -> Text -> FieldSettings UniWorX
-fslp label placeholder =
+fslp lbl placeholder =
-  FieldSettings { fsLabel    = (SomeMessage label)
+  FieldSettings { fsLabel    = (SomeMessage lbl)
                 , fsTooltip  = Nothing
                 , fsId       = Nothing
                 , fsName     = Nothing
@@ -403,8 +403,8 @@ fslp label placeholder =
   }
 
 fslpI :: RenderMessage UniWorX msg => msg -> Text -> FieldSettings UniWorX
-fslpI label placeholder =
+fslpI lbl placeholder =
-  FieldSettings { fsLabel    = (SomeMessage label)
+  FieldSettings { fsLabel    = (SomeMessage lbl)
                 , fsTooltip  = Nothing
                 , fsId       = Nothing
                 , fsName     = Nothing

src/Model/Types.hs

@@ -43,6 +43,9 @@ type Points = Centi
 toPoints :: Integral a => a -> Points
 toPoints = MkFixed . fromIntegral
 
+pToI :: Points -> Integer
+pToI = fromPoints -- TODO: do we want to multiply?
+
 fromPoints :: Integral a => Points -> a
 fromPoints (MkFixed c) = fromInteger c
 
@@ -52,6 +55,13 @@ data SheetType
   | Pass   { maxPoints, passingPoints :: Points }
   | NotGraded
   deriving (Show, Read, Eq)
+
+instance DisplayAble SheetType where
+  display (Bonus {..}) = tshow (pToI maxPoints) <> " Bonuspunkte"
+  display (Normal{..}) = tshow (pToI maxPoints) <> " Punkte"
+  display (Pass  {..}) = "Bestanden ab " <> tshow (pToI passingPoints) <> " von " <> tshow (pToI maxPoints)
+  display (NotGraded)  = "Unbewertet"
+
 deriveJSON defaultOptions ''SheetType
 derivePersistFieldJSON "SheetType"
 

src/Utils.hs

@@ -151,6 +151,16 @@ mcons :: Maybe a -> [a] -> [a]
 mcons Nothing  xs = xs
 mcons (Just x) xs = x:xs
 
+newtype NTop a = NTop a -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
+
+instance Eq a  => Eq (NTop (Maybe a)) where
+  (NTop x) == (NTop y) = x == y
+
+instance Ord a => Ord (NTop (Maybe a)) where
+  compare (NTop Nothing)  (NTop Nothing) = EQ
+  compare (NTop Nothing)  _              = GT
+  compare _               (NTop Nothing) = LT
+  compare (NTop (Just x)) (NTop (Just y)) = compare x y
 
 ---------------
 -- Exception --

templates/sheetShow.hamlet

@@ -13,7 +13,7 @@
                       <h2 #description>Hinweise
                       <p> #{descr}
                     <h3>Bewertung
-                    <p> #{show $ sheetType sheet}
+                    <p> #{display $ sheetType sheet}
                       $maybe marking <- sheetMarkingText sheet
                         <p> #{marking}
                     <br>

templates/submission.hamlet

@@ -46,7 +46,7 @@
           #{fileTitle file} 
           <span .label .label-warning>Gelöscht
       $else
-        <a href=@{SubmissionDownloadSingleR cID $ fileTitle file} download .list-group-item>
+        <a href=@{SubmissionDownloadSingleR cID' $ fileTitle file} download .list-group-item>
           #{fileTitle file}
           $if submissionFileIsUpdate sFile
             &nbsp;