diff --git a/routes b/routes index 37e2ebecb..7dd978fd6 100644 --- a/routes +++ b/routes @@ -50,20 +50,22 @@ !/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 -!/#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 \ No newline at end of file diff --git a/src/CryptoID.hs b/src/CryptoID.hs index d13e98425..7019689ea 100644 --- a/src/CryptoID.hs +++ b/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) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 2ae19143c..6e942e0be 100644 --- a/src/Handler/Course.hs +++ b/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 diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index da31ab516..3a711ff88 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/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 @@ -39,7 +54,7 @@ instance CryptoRoute UUID SubmissionId where Course{..} <- get404 sheetCourse return (courseTerm, courseShorthand, sheetName) return $ CSheetR tid csh shn $ SubmissionR cID - + class Dispatch ciphertext (x :: [*]) where dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX)) @@ -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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 3d738fe32..ed075c08c 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -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 diff --git a/templates/submission.hamlet b/templates/submission.hamlet index 469e076bb..0529e94aa 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -46,7 +46,7 @@ #{fileTitle file}  Gelöscht $else - + #{fileTitle file} $if submissionFileIsUpdate sFile