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

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

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/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/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

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;