fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
SJost 2018-06-21 16:47:47 +02:00
commit 1c9b121edb
6 changed files with 51 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
routes
View File

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

24
src/CryptoID.hs
View File

@ -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)

6
src/Handler/Course.hs
View File

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

23
src/Handler/CryptoIDDispatch.hs
View File

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

7
src/Handler/Submission.hs
View File

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

2
templates/submission.hamlet
View File

@ -46,7 +46,7 @@
#{fileTitle file}&nbsp;
<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;