Normalize paths & CryptoFileNameSubmission-prefix

models

@@ -83,6 +83,7 @@ CourseFavourite
     time         UTCTime
     course       CourseId
     UniqueCourseFavourite user course
+    deriving Show
 Lecturer 
     user         UserId
     course       CourseId

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)

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

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
+  cryptoIDRoute _ ciphertext
-    (smid :: SubmissionId) <- decrypt cID
+    | Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do
-    (tid,csh,shn) <- runDB $ do
+        smid <- decrypt cID
-      shid <- submissionSheet <$> get404 smid
+        (tid,csh,shn) <- runDB $ do
-      Sheet{..}  <- get404 shid
+          shid <- submissionSheet <$> get404 smid
-      Course{..} <- get404 sheetCourse
+          Sheet{..}  <- get404 shid
-      return (courseTerm, courseShorthand, sheetName)
+          Course{..} <- get404 sheetCourse
-    return $ CSubmissionR tid csh shn cID SubShowR
+          return (courseTerm, courseShorthand, sheetName)
+        return $ CSubmissionR tid csh shn cID SubShowR
+    | otherwise = notFound
 
 instance CryptoRoute UUID UserId where
   cryptoIDRoute _ (CryptoID -> cID) = do

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
 

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 piece <- stripPrefix "bewertung_" bName
-  = Just CryptoID{..}
+  , Just cID <- fromPathPiece $ Text.pack piece
+  = Just cID
   | otherwise
   = Nothing

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
+            tryDecrypt (Text.pack -> ciphertext)
-              sId <- decrypt (CryptoID (CI.mk segment) :: CryptoFileNameSubmission)
+              | Just cID <- fromPathPiece ciphertext = do
-              Just sId <$ get404 sId
+                  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
+  return sid