Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

models

@@ -98,6 +98,7 @@ Submission
     changed         UTCTime
     createdBy       UserId
     changedBy       UserId
+    deriving Show
 SubmissionFile
     submissionId    SubmissionId
     fileId          FileId 

routes

@@ -18,5 +18,8 @@
 /course/#TermIdentifier/#Text/edit CourseEditExistR GET
 /course/#TermIdentifier/#Text/show CourseShowR GET POST
 
+/submission                 SubmissionListR GET
+/submission/#CryptoUUIDSubmission SubmissionR GET POST
+
 -- For demonstration
 /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET

src/Application.hs

@@ -44,6 +44,7 @@ import Handler.Home
 import Handler.Profile
 import Handler.Term
 import Handler.Course
+import Handler.Submission
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the

src/Foundation.hs

@@ -173,6 +173,8 @@ instance Yesod UniWorX where
     isAuthorized CourseListR          _ = return Authorized    
     isAuthorized (CourseShowR _ _)    _ = return Authorized    
     isAuthorized (CourseListTermR _)  _ = return Authorized
+    isAuthorized SubmissionListR      _ = return Authorized
+    isAuthorized (SubmissionR _)      _ = return Authorized
     -- TODO: change to Assistants    
     isAuthorized TermEditR              _ = return Authorized
     isAuthorized (TermEditExistR _)     _ = return Authorized    
@@ -232,6 +234,9 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CourseShowR term course) = return (course, Just $ CourseListTermR term)
   breadcrumb CourseEditR = return ("Neu", Just CourseListR)  
   breadcrumb (CourseEditExistR _ _) = return ("Editieren", Just CourseListR)
+
+  breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
+  breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR)
   
   breadcrumb HomeR = return ("ReWorX", Nothing)
   breadcrumb (AuthR _) = return ("Login", Just HomeR)

src/Handler/Submission.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TupleSections #-}
+
+module Handler.Submission where
+
+import Import
+
+import Handler.Utils
+
+import qualified Data.UUID.Cryptographic as UUID
+
+
+getSubmissionListR :: Handler Html
+getSubmissionListR = do
+  entityList <- runDB $ selectList [] []
+  cIDKey <- getsYesod appCryptoIDKey
+  let
+    cryptEntity :: Entity Submission -> Handler (CryptoUUIDSubmission, Submission)
+    cryptEntity (Entity key val) = (, val) <$> UUID.encrypt cIDKey key
+  submissionList <- mapM cryptEntity entityList
+  defaultLayout $(widgetFile "submission-list")
+
+
+getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html
+getSubmissionR = postSubmissionR
+postSubmissionR cID = do
+  cIDKey <- getsYesod appCryptoIDKey
+  submissionID <- UUID.decrypt cIDKey cID
+  submission <- runDB $ get404 (submissionID :: Key Submission)
+
+  defaultLayout $ do
+    [whamlet|<pre>#{tshow submission}|]

src/Handler/Utils.hs

@@ -12,6 +12,9 @@ import Handler.Utils.Bootstrap3 as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
 import Handler.Utils.Table as Handler.Utils
 
+import Handler.Utils.Zip as Handler.Utils
+import Handler.Utils.Zip.Rating as Handler.Utils
+
 
 tickmark :: IsString a => a
 tickmark = fromString "✔"

src/Handler/Utils/Zip/Rating.hs

@@ -39,7 +39,6 @@ import qualified Data.Text.Lazy.Encoding as Lazy.Text
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
-import qualified Data.ByteString.Lazy as Lazy.ByteString
 
 import Text.Read (readEither)
 
@@ -82,7 +81,7 @@ getRating submissionId = runMaybeT $ do
   Sheet{ sheetCourseId, sheetName = ratingSheetName } <- MaybeT $ get submissionSheetId
   Course{ courseName = ratingCourseName } <- MaybeT $ get sheetCourseId
   cIDKey <- getsYesod appCryptoIDKey
-  ratingSubmissionId <- Poly.encrypt base32 cIDKey submissionId
+  ratingSubmissionId <- Poly.encrypt Nothing base32 cIDKey submissionId
   return Rating{..}
   where
     base32 = return . CI.foldCase . Text.unpack . Text.dropWhileEnd (== '=') . Text.decodeUtf8 . Base32.encode
@@ -157,12 +156,12 @@ isRatingFile fName
       (Just <$> Poly.decrypt unbase32 cIDKey cID) `catch` decryptErrors
   | otherwise = return Nothing
   where
-    unbase32 = either (const $ throwM CiphertextConversionFailed) return . Base32.decode . Text.encodeUtf8 . Text.pack . toUpper . (<> "===")
+    unbase32 = (\bs -> either (const . throwM $ CiphertextConversionFailed bs) return $ Base32.decode bs) . Text.encodeUtf8 . Text.pack . toUpper . (<> "===")
 
-    decryptErrors CiphertextConversionFailed = return Nothing
-    decryptErrors InvalidNamespaceDetected   = return Nothing
-    decryptErrors (DeserializationError _)   = return Nothing
-    decryptErrors err                        = throwM err
+    decryptErrors (CiphertextConversionFailed _) = return Nothing
+    decryptErrors InvalidNamespaceDetected       = return Nothing
+    decryptErrors DeserializationError           = return Nothing
+    decryptErrors err                            = throwM err
 
 isRatingFile' :: FilePath -> Maybe (CryptoIDSubmission String)
 isRatingFile' (takeFileName -> fName)

stack.yaml

@@ -10,7 +10,7 @@ extra-deps:
 - colonnade-1.1.1
 - yesod-colonnade-1.1.0
 - zip-stream-0.1.0.1
-- uuid-crypto-1.1.1.0
-- cryptoids-0.2.0.0
+- uuid-crypto-1.3.0.0
+- cryptoids-0.3.0.0
 - cryptoids-types-0.0.0
 resolver: lts-9.3

templates/submission-list.hamlet

@@ -0,0 +1,4 @@
+<ul>
+  $forall (cID, val) <- submissionList
+    <li>
+      <a href=@{SubmissionR cID}>#{tshow $ ciphertext cID}