From 11895f670927d6e0c9a39bff6498aa4daa486d10 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 11 Oct 2017 00:00:20 +0200 Subject: [PATCH 1/3] Bump CryptoID --- src/Handler/Utils/Zip/Rating.hs | 13 ++++++------- stack.yaml | 4 ++-- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Handler/Utils/Zip/Rating.hs b/src/Handler/Utils/Zip/Rating.hs index 1f48e0e5e..db1641d94 100644 --- a/src/Handler/Utils/Zip/Rating.hs +++ b/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) diff --git a/stack.yaml b/stack.yaml index 098f9e359..e58283b00 100644 --- a/stack.yaml +++ b/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.2.0.0 +- cryptoids-0.3.0.0 - cryptoids-types-0.0.0 resolver: lts-9.3 From f7f7c7c5929e4e3424d1ac35709c46f5e9aea5be Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 11 Oct 2017 00:18:09 +0200 Subject: [PATCH 2/3] Dump submissions --- models | 1 + routes | 3 +++ src/Application.hs | 1 + src/Foundation.hs | 5 ++++ src/Handler/Submission.hs | 39 ++++++++++++++++++++++++++++++++ src/Handler/Utils.hs | 3 +++ stack.yaml | 2 +- templates/submission-list.hamlet | 4 ++++ 8 files changed, 57 insertions(+), 1 deletion(-) create mode 100644 src/Handler/Submission.hs create mode 100644 templates/submission-list.hamlet diff --git a/models b/models index 1fd956be7..3c2d66b55 100644 --- a/models +++ b/models @@ -98,6 +98,7 @@ Submission changed UTCTime createdBy UserId changedBy UserId + deriving Show SubmissionFile submissionId SubmissionId fileId FileId diff --git a/routes b/routes index 10f0aa4d8..836782a5a 100644 --- a/routes +++ b/routes @@ -18,5 +18,8 @@ /course/#TermIdentifier/#Text/edit CourseEditExistR GET /course/#TermIdentifier/#Text/show CourseShowR GET +/submission SubmissionListR GET +/submission/#CryptoUUIDSubmission SubmissionR GET POST + -- For demonstration /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET diff --git a/src/Application.hs b/src/Application.hs index 563c208fa..3ab73b289 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 54ebfc18b..733089953 100644 --- a/src/Foundation.hs +++ b/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) diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs new file mode 100644 index 000000000..3a26ef586 --- /dev/null +++ b/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 (traceShowId 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|
#{tshow submission}|]
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index 0dfaa8721..27d04a8b0 100644
--- a/src/Handler/Utils.hs
+++ b/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 "✔"
diff --git a/stack.yaml b/stack.yaml
index e58283b00..7cc6221eb 100644
--- a/stack.yaml
+++ b/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.2.0.0
+- uuid-crypto-1.3.0.0
 - cryptoids-0.3.0.0
 - cryptoids-types-0.0.0
 resolver: lts-9.3
diff --git a/templates/submission-list.hamlet b/templates/submission-list.hamlet
new file mode 100644
index 000000000..eb64b5146
--- /dev/null
+++ b/templates/submission-list.hamlet
@@ -0,0 +1,4 @@
+