diff --git a/models b/models index 47f6f824a..e68c47c43 100644 --- a/models +++ b/models @@ -83,6 +83,7 @@ CourseFavourite time UTCTime course CourseId UniqueCourseFavourite user course + deriving Show Lecturer user UserId course CourseId diff --git a/src/CryptoID.hs b/src/CryptoID.hs index b8b4b2eed..3b5efceec 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -20,6 +20,7 @@ import CryptoID.TH import ClassyPrelude hiding (fromString) import Model +import qualified Data.CryptoID as E import Data.CryptoID.Poly.ImplicitNamespace import Data.UUID.Cryptographic.ImplicitNamespace import System.FilePath.Cryptographic.ImplicitNamespace @@ -39,7 +40,7 @@ instance PathPiece UUID where instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where fromPathPiece = fmap CI.mk . fromPathPiece - toPathPiece = toPathPiece . CI.foldedCase + toPathPiece = toPathPiece . CI.original instance {-# OVERLAPS #-} PathMultiPiece FilePath where fromPathMultiPiece = Just . unpack . intercalate "/" @@ -55,8 +56,12 @@ decCryptoIDs [ ''SubmissionId , ''FileId , ''UserId ] -{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -} +instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where + fromPathPiece (Text.unpack -> piece) = do + piece' <- (stripPrefix `on` map CI.mk) "uwa" piece + return . CryptoID . CI.mk $ map CI.original piece' + toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission) diff --git a/src/Foundation.hs b/src/Foundation.hs index 2049e7172..51d839610 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -9,9 +9,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards, MultiWayIf #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts #-} module Foundation where @@ -25,7 +25,7 @@ import Yesod.Auth.Message import Yesod.Auth.Dummy import Yesod.Auth.LDAP -import qualified Network.Wai as W (requestMethod) +import qualified Network.Wai as W (requestMethod, pathInfo) import LDAP.Data (LDAPScope(..)) import LDAP.Search (LDAPEntry(..)) @@ -37,14 +37,14 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Data.Text.Encoding as TE +import qualified Data.CryptoID as E + import Data.ByteArray (convert) import Crypto.Hash (Digest, SHAKE256) import Crypto.Hash.Conduit (sinkHash) import Yesod.Auth.Util.PasswordStore -import qualified Data.CryptoID (CryptoID) -- for DisplayAble instance only - import qualified Data.ByteString.Base64.URL as Base64 (encode) import Data.ByteString (ByteString) @@ -60,6 +60,8 @@ import qualified Data.Set as Set import Data.Map (Map, (!?)) import qualified Data.Map as Map +import Data.Monoid (Any(..)) + import Data.Conduit (($$)) import Data.Conduit.List (sourceList) @@ -69,6 +71,9 @@ import qualified Database.Esqueleto as E import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (runReader) +import Control.Monad.Trans.Writer (WriterT(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Catch (handleAll) import System.FilePath @@ -85,15 +90,15 @@ import qualified Data.Yaml as Yaml import Text.Shakespeare.Text (st) +instance DisplayAble b => DisplayAble (E.CryptoID a b) where + display = display . ciphertext + +instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => DisplayAble (E.CryptoID namespace (CI FilePath)) where + display = toPathPiece --- -- TODO: Move the following to the appropriate place, if DisplayAble is kept instance DisplayAble TermId where display = termToText . unTermKey -instance (PathPiece b) => DisplayAble (Data.CryptoID.CryptoID a b) where - display = toPathPiece -- requires import of Data.CryptoID here --- -- MOVE ABOVE - -- infixl 9 :$: -- pattern a :$: b = a b @@ -449,24 +454,28 @@ instance Yesod UniWorX where -- b) Validates that incoming write requests include that token in either a header or POST parameter. -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. - yesodMiddleware = updateFavouritesMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware + yesodMiddleware = defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware where updateFavouritesMiddleware :: Handler a -> Handler a updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do route <- MaybeT getCurrentRoute - guardM . lift $ (== Authorized) <$> isAuthorized route False case route of -- update Course Favourites here CourseR tid csh _ -> do - uid <- MaybeT maybeAuthId - $(logDebug) "Favourites save" - now <- liftIO $ getCurrentTime void . lift . runDB . runMaybeT $ do + guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid csh CShowR) False + $logDebugS "updateFavourites" "Updating favourites" + + now <- liftIO $ getCurrentTime + uid <- MaybeT $ liftHandlerT maybeAuthId cid <- MaybeT . getKeyBy $ CourseTermShort tid csh user <- MaybeT $ get uid + let courseFavourite = CourseFavourite uid now cid + + $logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|] -- update Favourites void . lift $ upsertBy (UniqueCourseFavourite uid cid) - (CourseFavourite uid now cid) + courseFavourite [CourseFavouriteTime =. now] -- prune Favourites to user-defined size oldFavs <- lift $ selectKeysList @@ -474,8 +483,17 @@ instance Yesod UniWorX where [ Desc CourseFavouriteTime , OffsetBy $ userMaxFavourites user ] - lift $ mapM_ delete oldFavs + lift . forM_ oldFavs $ \fav -> do + $logDebugS "updateFavourites" "Deleting old favourite." + delete fav _other -> return () + normalizeRouteMiddleware :: Handler a -> Handler a + normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do + route <- MaybeT getCurrentRoute + (route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers + when changed $ do + $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|] + redirectWith movedPermanently301 route' -- The following exception permits drive-by login via LDAP plugin. FIXME: Blocked by #17 isWriteRequest (AuthR (PluginR "LDAP" _)) = return False @@ -985,6 +1003,42 @@ pageHeading _ = Nothing +routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)] +routeNormalizers = + [ normalizeRender + , ncCourse + , ncSheet + ] + where + normalizeRender route = route <$ do + YesodRequest{..} <- liftHandlerT getRequest + let original = (W.pathInfo reqWaiRequest, reqGetParams) + rendered = renderRoute route + if + | (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic + $logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|] + | otherwise -> do + $logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|] + tell $ Any True + maybeOrig f route = maybeT (return route) $ f route + hasChanged a b + | ((/=) `on` CI.original) a b = do + $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|] + tell $ Any True + | otherwise = return () + ncCourse = maybeOrig $ \route -> do + CourseR tid csh subRoute <- return route + Entity _ Course{..} <- MaybeT . lift . getBy $ CourseTermShort tid csh + hasChanged csh courseShorthand + return $ CourseR tid courseShorthand subRoute + ncSheet = maybeOrig $ \route -> do + CSheetR tid csh shn subRoute <- return route + Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh + Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn + hasChanged shn sheetName + return $ CSheetR tid csh sheetName subRoute + + -- How to run database actions. instance YesodPersist UniWorX where type YesodPersistBackend UniWorX = SqlBackend diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 32781c28d..6f198828b 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -21,7 +21,7 @@ import Import hiding (Proxy) import Data.Proxy -import Handler.Utils +import qualified Data.Text as Text import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) @@ -46,14 +46,16 @@ instance CryptoRoute UUID SubmissionId where return $ CSubmissionR tid csh shn cID' SubShowR instance CryptoRoute (CI FilePath) SubmissionId where - cryptoIDRoute _ (CryptoID -> cID) = do - (smid :: SubmissionId) <- decrypt cID - (tid,csh,shn) <- runDB $ do - shid <- submissionSheet <$> get404 smid - Sheet{..} <- get404 shid - Course{..} <- get404 sheetCourse - return (courseTerm, courseShorthand, sheetName) - return $ CSubmissionR tid csh shn cID SubShowR + cryptoIDRoute _ ciphertext + | Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do + smid <- decrypt cID + (tid,csh,shn) <- runDB $ do + shid <- submissionSheet <$> get404 smid + Sheet{..} <- get404 shid + Course{..} <- get404 sheetCourse + return (courseTerm, courseShorthand, sheetName) + return $ CSubmissionR tid csh shn cID SubShowR + | otherwise = notFound instance CryptoRoute UUID UserId where cryptoIDRoute _ (CryptoID -> cID) = do diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 37e2c9c56..73f68f988 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -343,7 +343,7 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = error "Multiple matching files found." getSubArchiveR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent -getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do +getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do when (sfType == SubmissionCorrected) $ guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 9fa4b97d1..7702a7d52 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -133,7 +133,7 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let , ("Korrektor:" <+>) . pretty <$> ratingCorrectorName , Just $ "Bewertung:" <+> pretty (display ratingSheetType) ] - , "Abgabe-Id:" <+> pretty (ciphertext cID) + , "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID) , "=============================================" , "Bewertung:" <+> pretty ratingPoints , "=========== Beginn der Kommentare ===========" @@ -145,7 +145,7 @@ ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do fileModified <- maybe (liftIO getCurrentTime) return ratingTime let - fileTitle = "bewertung_" <> (CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)) <.> "txt" + fileTitle = "bewertung_" <> (Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)) <.> "txt" fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating return File{..} @@ -212,7 +212,8 @@ isRatingFile fName isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission isRatingFile' (takeFileName -> fName) | (bName, ".txt") <- splitExtension fName - , Just (CI.mk -> ciphertext) <- stripPrefix "bewertung_" bName - = Just CryptoID{..} + , Just piece <- stripPrefix "bewertung_" bName + , Just cID <- fromPathPiece $ Text.pack piece + = Just cID | otherwise = Nothing diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 28a8a3abc..097a505d8 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -10,6 +10,7 @@ {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE FlexibleContexts #-} module Handler.Utils.Submission @@ -43,6 +44,8 @@ import qualified Data.Set as Set import Data.Map (Map, (!?)) import qualified Data.Map as Map +import qualified Data.Text as Text + import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -159,7 +162,7 @@ submissionMultiArchive (Set.toList -> ids) = do cID <- encrypt submissionID let - directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission) + directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission) fileEntitySource = do submissionFileSource submissionID =$= Conduit.map entityVal @@ -480,9 +483,11 @@ sinkMultiSubmission userId isUpdate = do acc (Just sId, fp) segment = return (Just sId, fp ++ [segment]) acc (Nothing , fp) segment = do let - tryDecrypt ciphertext = do - sId <- decrypt (CryptoID (CI.mk segment) :: CryptoFileNameSubmission) - Just sId <$ get404 sId + tryDecrypt (Text.pack -> ciphertext) + | Just cID <- fromPathPiece ciphertext = do + sId <- decrypt (cID :: CryptoFileNameSubmission) + Just sId <$ get404 sId + | otherwise = return Nothing msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ] return (msId, fp) (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle @@ -515,4 +520,4 @@ submissionMatchesSheet tid csh shn cid = do shid <- fetchSheetId tid csh shn Submission{..} <- get404 sid when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] - return sid \ No newline at end of file + return sid