fix(downloads): do download links via redirect

src/Foundation/Instances.hs

@@ -83,15 +83,6 @@ instance Yesod UniWorX where
             Nothing -> getApprootText guessApproot app req
             Just root -> root
 
-    urlParamRenderOverride app route params = do
-      rApproot <- case authoritiveApproot route of
-        ApprootDefault -> mzero
-        rApproot -> return rApproot
-      guard $ views _appRoot ($ ApprootDefault) app /= views _appRoot ($ rApproot) app
-      approotText <- app ^. _appRoot . to ($ rApproot) 
-      let (ps, params') = renderRoute route
-      return . joinPath app approotText ps $ params ++ params'
-
     makeSessionBackend = UniWorX.makeSessionBackend
 
     maximumContentLength app _ = app ^. _appMaximumContentLength

src/Foundation/Yesod/Middleware.hs

@@ -31,7 +31,7 @@ yesodMiddleware :: ( BearerAuthSite UniWorX
                    , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
                    )
                 => HandlerFor UniWorX res -> HandlerFor UniWorX res
-yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . securityMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware . setActiveAuthTagsMiddleware
+yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . securityMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware . setActiveAuthTagsMiddleware . normalizeApprootMiddleware
   where
     dryRunMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
     dryRunMiddleware handler = do
@@ -135,6 +135,30 @@ yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddlewar
       handler
     cacheControlMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
     cacheControlMiddleware = (addHeader "Vary" "Accept, Accept-Language" *>)
+    normalizeApprootMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    normalizeApprootMiddleware handler = maybeT handler $ do
+      route <- MaybeT getCurrentRoute
+      reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
+      let rApproot = authoritiveApproot route 
+      app <- getYesod
+      approotHost <- hoistMaybe $ approotScopeHost rApproot app
+      let doRedirect = do
+            url <- approotRender rApproot route
+            $logErrorS "normalizeApprootMiddleware" url
+            redirect url
+      if | approotHost /= reqHost
+         , rApproot /= ApprootUserGenerated
+           -> doRedirect
+         | approotHost /= reqHost -> do
+             resp <- try $ lift handler
+             $logErrorS "normalizeApprootMiddleware" $ tshow (is _Right resp, preview _Left resp)
+             case resp of
+               Right _ -> doRedirect
+               Left sc | is _HCRedirect sc -> throwM sc
+               Left _ -> doRedirect
+         | otherwise -> lift handler
+    
+
 
 updateFavourites :: forall m backend.
                     ( MonadHandler m, HandlerSite m ~ UniWorX
@@ -175,8 +199,7 @@ routeNormalizers :: forall m backend.
                     , BearerAuthSite UniWorX
                     ) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)]
 routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .)
-  [ normalizeApproot
+  [ normalizeRender
-  , normalizeRender
   , ncSchool
   , ncAllocation
   , ncCourse
@@ -195,12 +218,6 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
   , verifyMaterialVideo
   ]
   where
-    normalizeApproot route = (route <$) . runMaybeT $ do
-      reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
-      approotHost <- MaybeT . getsYesod . approotScopeHost $ authoritiveApproot route
-      when (approotHost /= reqHost) $
-        tell $ Any True
-    
     normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
     normalizeRender route = route <$ do
       YesodRequest{..} <- liftHandler getRequest

src/Handler/Allocation/AddUser.hs

@@ -13,8 +13,6 @@ import qualified Data.Conduit.Combinators as C
 
 import qualified Database.Esqueleto as E
 
-import Handler.Course.Show
-
 
 data AllocationAddUserForm = AllocationAddUserForm
   { aauUser :: UserId
@@ -121,7 +119,7 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor
     mApplicationTemplate <- runMaybeT $ do
       guard hasApplicationTemplate
       let Course{..} = course
-      liftHandler . runDB $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource courseTerm courseSchool courseShorthand) $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
+      toTextUrl $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
     over _2 (course, allocCourse, mApplicationTemplate, ) <$> applicationForm (Just aId) cId Nothing ApplicationFormMode{..} Nothing
   let appsRes = sequenceA $ view _1 <$> appsRes'
       appsViews = view _2 <$> appsRes'

src/Handler/Allocation/Application.hs

@@ -141,7 +141,7 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr
   appFilesInfo <- for mApp $ \(Entity appId _) -> liftHandler . runDB $ do
     hasFiles <- exists [ CourseApplicationFileApplication ==. appId ]
     appCID <- encrypt appId
-    appFilesLink <- toTextUrl <=< withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
+    appFilesLink <- toTextUrl $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
     return (hasFiles, appFilesLink)
   let hasFiles = maybe False (view _1) appFilesInfo
 

src/Handler/Allocation/Show.hs

@@ -15,8 +15,6 @@ import Handler.Allocation.Application
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
-import Handler.Course.Show
-
 
 data NotifyNewCourseButton
   = BtnNotifyNewCourseForceOn
@@ -178,7 +176,7 @@ postAShowR tid ssh ash = do
             Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR
           mApplicationTemplate <- runMaybeT $ do
             guard hasApplicationTemplate
-            liftHandler . runDB $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource courseTerm courseSchool courseShorthand) $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
+            toTextUrl $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
 
           let mApplyFormView' = view _1 <$> mApplyFormView
               overrideVisible = not mayApply && is _Just mApp

src/Handler/Course/Register.hs

@@ -104,7 +104,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
     appFilesInfo <- for application $ \(Entity appId _) -> liftHandler . runDB $ do
       hasFiles <- exists [ CourseApplicationFileApplication ==. appId ]
       appCID <- encrypt appId
-      appFilesLink <- toTextUrl <=< withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
+      appFilesLink <- toTextUrl $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
       return (hasFiles, appFilesLink)
     let hasFiles = maybe False (view _1) appFilesInfo
         filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired

src/Handler/Course/Show.hs

@@ -25,8 +25,6 @@ import qualified Data.Conduit.List as C
 
 import Handler.Exam.List (mkExamTable)
 
-import Handler.Course.News.Download
-
 
 getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
@@ -80,7 +78,7 @@ getCShowR tid ssh csh = do
       E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
     mApplicationTemplate <- runMaybeT $ do
       guard hasApplicationTemplate
-      lift . lift $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource tid ssh csh) $ CourseR tid ssh csh CRegisterTemplateR
+      lift . lift . toTextUrl $ CourseR tid ssh csh CRegisterTemplateR
     mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
     news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ]
     cTime <- NTop . Just <$> liftIO getCurrentTime
@@ -98,8 +96,8 @@ getCShowR tid ssh csh = do
       mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
       mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR
 
-      files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl <=< withFileDownloadToken (cnFileSource nId fPath) . CNewsR tid ssh csh cID $ CNFileR fPath
+      files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl . CNewsR tid ssh csh cID $ CNFileR fPath
-      archiveUrl <- lift . lift $ toTextUrl <=< withFileDownloadToken (cnArchiveSource nId) $ CNewsR tid ssh csh cID CNArchiveR
+      archiveUrl <- lift . lift . toTextUrl $ CNewsR tid ssh csh cID CNArchiveR
 
       return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete, archiveUrl)
 

src/Handler/Material.hs

@@ -83,9 +83,8 @@ getMaterialListR tid ssh csh = do
   let matLink :: MaterialName -> Route UniWorX
       matLink = CourseR tid ssh csh . flip MaterialR MShowR
 
-      filesLink :: (MonadHandler m, HandlerSite m ~ UniWorX)
+      filesLink :: MaterialName -> SomeRoute UniWorX
-                => MaterialName -> m (SomeRoute UniWorX)
+      filesLink mnm = SomeRoute . CourseR tid ssh csh $ MaterialR mnm MArchiveR 
-      filesLink mnm = liftHandler . runDB $ withFileDownloadToken (materialArchiveSource tid ssh csh mnm) . CourseR tid ssh csh $ MaterialR mnm MArchiveR 
 
       materialModDateCell :: IsDBTable m a => Material -> DBCell m a
       materialModDateCell Material{materialVisibleFrom, materialLastEdit}
@@ -124,7 +123,7 @@ getMaterialListR tid ssh csh = do
             , sortable (toNothingS "zip-archive") (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgMaterialFiles))
                 $ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if
                   | fileNum == 0 -> mempty
-                  | otherwise    -> anchorCellM (filesLink materialName) iconFileDownload
+                  | otherwise    -> anchorCell (filesLink materialName) iconFileDownload
             , sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
                 $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
             , sortable (Just "last-edit") (i18nCell MsgFileModified)
@@ -177,10 +176,10 @@ getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal
 getMVideoR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> CryptoUUIDMaterialFile -> Handler Html
 getMVideoR tid ssh csh mnm cID = do
   mfId <- decrypt cID
-  mf@MaterialFile{..} <- runDB $ get404 mfId
+  MaterialFile{..} <- runDB $ get404 mfId
   let mimeType = mimeLookup $ pack materialFileTitle
-  mfile <- withFileDownloadToken (views (_FileReference . _1) yield mf) . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
+      mfile = CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
-  let mfileDownload = mfile & over (urlRouteParams $ Proxy @UniWorX) (\params -> bool ((toPathPiece GetDownload, mempty) : ) id (anyOf (folded . _1) (== toPathPiece GetDownload) params) params)
+  let mfileDownload = mfile & over (urlRouteParams $ Proxy @UniWorX) (\params -> bool ((toPathPiece GetDownload, toPathPiece True) : ) id (anyOf (folded . _1) (== toPathPiece GetDownload) params) params)
   mfileText <- toTextUrl mfile
   mfileDownloadText <- toTextUrl mfileDownload
   unless (mimeType `Set.member` videoTypes) $
@@ -206,7 +205,7 @@ getMShowR tid ssh csh mnm = do
   seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility
 
   (Entity _mid material@Material{materialType, materialDescription}, (Any hasFiles,fileTable), zipLink) <- runDB $ do
-    zipLink <- withFileDownloadToken (materialArchiveSource tid ssh csh mnm) $ CMaterialR tid ssh csh mnm MArchiveR
+    let zipLink = CMaterialR tid ssh csh mnm MArchiveR
     matEnt <- fetchMaterial tid ssh csh mnm
     let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
         materialModDateCol = if seeAllModificationTimestamps
@@ -220,12 +219,12 @@ getMShowR tid ssh csh mnm = do
             return matFile
       , dbtRowKey = (E.^. MaterialFileId)
       , dbtColonnade = widgetColonnade $ mconcat
-            [ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \(dbrOutput -> Entity mfId mf@MaterialFile{..})
+            [ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \(dbrOutput -> Entity mfId MaterialFile{..})
                 -> let matLink
                          | isVideo
-                         = SomeRoute . CourseR tid ssh csh . MaterialR mnm . MVideoR <$> encrypt mfId
+                         = CourseR tid ssh csh . MaterialR mnm . MVideoR <$> encrypt mfId
                          | otherwise
-                         = withFileDownloadToken (views (_FileReference . _1) yield mf) . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
+                         = pure . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
                        wgt = [whamlet|
                                $newline never
                                <span .file-path>

src/Handler/Sheet/List.hs

@@ -54,10 +54,10 @@ getSheetListR tid ssh csh = do
               [ icnCell & addIconFixedWidth
               | let existingSFTs = hasSFT existFiles
               , sft <- [minBound..maxBound]
-              , let link = liftHandler . runDB . withFileDownloadToken (sheetFilesAllQuery tid ssh csh sheetName muid sft) . CSheetR tid ssh csh sheetName $ SZipR sft
+              , let link = CSheetR tid ssh csh sheetName $ SZipR sft
               , let icn  = toWgt $ sheetFile2markup sft
               , let icnCell = if sft `elem` existingSFTs
-                              then linkEitherCellM link (icn, [whamlet|&emsp;|])
+                              then linkEitherCell link (icn, [whamlet|&emsp;|])
                               else spacerCell
               ] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
       , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)

src/Handler/Sheet/Show.hs

@@ -50,14 +50,14 @@ getSShowR tid ssh csh shn = do
                )
   let colonnadeFiles = widgetColonnade $ mconcat
         [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype, _) ->
-            let link = liftHandler . runDB . withFileDownloadToken (sheetFilesAllQuery tid ssh csh shn muid ftype) . CSheetR tid ssh csh shn $ SZipR ftype
+            let link = CSheetR tid ssh csh shn $ SZipR ftype
              in tellCell (Any True) $
-                  anchorCellM link [whamlet|#{sheetFile2markup ftype}  _{ftype}|]
+                  anchorCell link [whamlet|#{sheetFile2markup ftype}  _{ftype}|]
             -- i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
 
         -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName))))
-        , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,E.Value fMod,E.Value fType, E.Value fRef) -> anchorCellM
+        , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName, _, E.Value fType, _) -> anchorCell
-             (withFileDownloadToken (yield $ FileReference fName fRef fMod) $ CSheetR tid ssh csh shn (SFileR fType fName))
+             (CSheetR tid ssh csh shn $ SFileR fType fName)
              (str2widget fName)
         , sortable (toNothing "visible") (i18nCell MsgVisibleFrom)
             $ \(_,              _ , E.Value ftype, _) -> sftVisible ftype

src/Handler/Submission/Correction.hs

@@ -17,8 +17,6 @@ import qualified Control.Monad.State.Class as State
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
-import Handler.Submission.Download
-
 
 correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
 correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
@@ -146,7 +144,7 @@ postCorrectionR tid ssh csh shn cid = do
             |]
       siteLayout headingWgt $ do
         setTitleI heading
-        urlArchive <- toTextUrl <=< liftHandler . runDB . withFileDownloadToken' (subArchiveSource tid ssh csh shn cid SubmissionCorrected) . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected
+        urlArchive <- toTextUrl . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected
         let userCorrection = $(widgetFile "correction-user")
         $(widgetFile "correction")
     _ -> notFound
@@ -159,6 +157,6 @@ getCorrectionUserR tid ssh csh shn cid = do
     [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _), E.Value filesCorrected)] ->
       let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment
        in defaultLayout $ do
-            urlArchive <- toTextUrl <=< liftHandler . runDB . withFileDownloadToken' (subArchiveSource courseTerm courseSchool courseShorthand sheetName cid SubmissionCorrected) . CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected
+            urlArchive <- toTextUrl . CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected
             $(widgetFile "correction-user")
     _ -> notFound

src/Handler/Submission/Helper.hs

@@ -27,8 +27,6 @@ import Text.Blaze (Markup)
 import qualified Data.Aeson.Types as JSON
 import Data.Aeson.Lens
 
-
-import Handler.Submission.Download
 import Handler.Submission.SubmissionUserInvite
 
 
@@ -491,12 +489,12 @@ submissionHelper tid ssh csh shn mcid = do
               corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr
               Just isFile = origIsFile <|> corrIsFile
             in if
-              | Just True <- origIsFile -> anchorCellM (subDownloadLink cid SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
+              | Just True <- origIsFile -> anchorCell (subDownloadLink cid SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
               | otherwise               -> textCell $ bool (<> "/") id isFile fileTitle'
         , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgCorState) $ \(_, mCorr) -> case mCorr of
             Nothing -> cell mempty
             Just (Entity _ SubmissionFile{..})
-              | isJust submissionFileContent -> anchorCellM (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget)
+              | isJust submissionFileContent -> anchorCell (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget)
               | otherwise -> i18nCell MsgCorrected
         , Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(mOrig, mCorr) -> let
               origTime = submissionFileModified . entityVal <$> mOrig
@@ -504,8 +502,7 @@ submissionHelper tid ssh csh shn mcid = do
               Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
             in dateTimeCell fileTime
         ]
-      subDownloadLink :: _ -> _ -> _ -> WidgetFor UniWorX _
+      subDownloadLink cid sft fileTitle' = CSubmissionR tid ssh csh shn cid $ SubDownloadR sft fileTitle'
-      subDownloadLink cid sft fileTitle' = liftHandler . runDB . withFileDownloadToken (subDownloadSource tid ssh csh shn cid sft fileTitle') . CSubmissionR tid ssh csh shn cid $ SubDownloadR sft fileTitle'
       submissionFiles :: _ -> _ -> E.SqlQuery _
       submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do
         E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle
@@ -555,7 +552,7 @@ submissionHelper tid ssh csh shn mcid = do
   defaultLayout $ do
     setTitleI $ MsgSubmissionEditHead tid ssh csh shn
     (urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID
-      -> let mkUrl sft = toTextUrl <=< withFileDownloadToken' (subArchiveSource tid ssh csh shn cID sft) . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft
+      -> let mkUrl sft = toTextUrl . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft
           in liftHandler . runDB $ (,) <$> mkUrl SubmissionCorrected <*> mkUrl SubmissionOriginal
     let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) ->
           let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment

src/Handler/Utils/ContentDisposition.hs

@@ -18,6 +18,6 @@ downloadFiles = do
 
 setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Maybe FilePath -> m ()
 setContentDisposition' mFileName = do
-  wantsDownload <- or2M (hasGlobalGetParam GetDownload) downloadFiles
+  wantsDownload <- maybeT downloadFiles . MaybeT $ lookupGlobalGetParam GetDownload
   setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName
 

src/Handler/Utils/Download.hs

@@ -1,6 +1,5 @@
 module Handler.Utils.Download
-  ( withFileDownloadTokenMaybe', withFileDownloadToken, withFileDownloadToken'
+  ( sendThisFile
-  , sendThisFile
   , sendFileReference
   , serveOneFile
   , serveSomeFiles
@@ -22,6 +21,8 @@ import Handler.Utils.Zip
 import Handler.Utils.ContentDisposition
 import Handler.Utils.Files
 
+import qualified Network.Wai as W
+
 
 data DownloadTokenRestriction
   = DownloadRestrictSingle { downloadRestrictReference :: FileContentReference }
@@ -70,55 +71,90 @@ withFileDownloadTokenMaybe' mSource route = maybeT (return $ SomeRoute route) $
   encodedBearer <- lift $ encodeBearer bearer
 
   lift . setDownload $ SomeRoute @UniWorX route
-    & over (urlRouteParams $ Proxy @UniWorX) ((toPathPiece GetBearer, toPathPiece encodedBearer) :)
+    & over (urlRouteParams $ Proxy @UniWorX) (((toPathPiece GetBearer, toPathPiece encodedBearer) :) . filter (views _1 (maybe False (/= GetBearer) . fromPathPiece)))
 
   where
     setDownload :: SomeRoute UniWorX -> m (SomeRoute UniWorX)
     setDownload route' = do
       wantsDownload <- downloadFiles
+      defWantsDownload <- getsYesod $ views _appUserDefaults userDefaultDownloadFiles
+      let
+        addDownload params
+          | anyOf (folded . _1) (== toPathPiece GetDownload) params = params
+          | otherwise = (toPathPiece GetDownload, toPathPiece wantsDownload) : params
       return $ route'
-        & over (urlRouteParams $ Proxy @UniWorX) (bool id addDownload wantsDownload)
+        & over (urlRouteParams $ Proxy @UniWorX) (bool id addDownload $ wantsDownload /= defWantsDownload)
-      where
-        addDownload params | anyOf (folded . _1) (== toPathPiece GetDownload) params = params
-                           | otherwise = (toPathPiece GetDownload, mempty) : params
 
-withFileDownloadToken' :: forall file url m.
+-- withFileDownloadToken' :: forall file url m.
-                          ( HasFileReference file
+--                           ( HasFileReference file
-                          , HasRoute UniWorX url
+--                           , HasRoute UniWorX url
-                          , MonadHandler m, HandlerSite m ~ UniWorX
+--                           , MonadHandler m, HandlerSite m ~ UniWorX
-                          , MonadCrypto m
+--                           , MonadCrypto m
-                          , MonadCryptoKey m ~ CryptoIDKey
+--                           , MonadCryptoKey m ~ CryptoIDKey
-                          , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
+--                           , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
-                          )
+--                           )
-                       => ConduitT () (Either file DBFile) m ()
+--                        => ConduitT () (Either file DBFile) m ()
-                       -> url
+--                        -> url
-                       -> m (SomeRoute UniWorX)
+--                        -> m (SomeRoute UniWorX)
-withFileDownloadToken' = withFileDownloadTokenMaybe' . Just . (.| C.map (first . view $ _FileReference . _1))
+-- withFileDownloadToken' = withFileDownloadTokenMaybe' . Just . (.| C.map (first . view $ _FileReference . _1))
 
 
-withFileDownloadToken :: forall file url m.
+-- withFileDownloadToken :: forall file url m.
-                         ( HasFileReference file
+--                          ( HasFileReference file
-                         , HasRoute UniWorX url
+--                          , HasRoute UniWorX url
-                         , MonadHandler m, HandlerSite m ~ UniWorX
+--                          , MonadHandler m, HandlerSite m ~ UniWorX
-                         , MonadCrypto m
+--                          , MonadCrypto m
-                         , MonadCryptoKey m ~ CryptoIDKey
+--                          , MonadCryptoKey m ~ CryptoIDKey
-                         , BearerAuthSite UniWorX
+--                          , BearerAuthSite UniWorX
-                         )
+--                          )
-                      => ConduitT () file m ()
+--                       => ConduitT () file m ()
-                      -> url
+--                       -> url
-                      -> m (SomeRoute UniWorX)
+--                       -> m (SomeRoute UniWorX)
-withFileDownloadToken = withFileDownloadToken' . (.| C.map Left)
+-- withFileDownloadToken = withFileDownloadToken' . (.| C.map Left)
+
+ensureApprootUserGeneratedMaybe'
+  :: forall m.
+     ( MonadHandler m, HandlerSite m ~ UniWorX
+     , MonadCrypto m
+     , MonadCryptoKey m ~ CryptoIDKey
+     , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
+     )
+  => Maybe (ConduitT () (Either FileReference DBFile) m ())
+  -> m ()
+ensureApprootUserGeneratedMaybe' source = maybeT (return ()) $ do
+  route <- (,) <$> MaybeT getCurrentRoute <*> fmap reqGetParams getRequest
+  $logErrorS "ensureApproot" $ tshow route
+  rApproot <- hoistMaybe <=< lift . runMaybeT $ do
+    reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
+    let rApproot = authoritiveApproot $ urlRoute route 
+    guard $ rApproot == ApprootUserGenerated
+    approotHost <- MaybeT . getsYesod $ approotScopeHost rApproot
+    guard $ approotHost /= reqHost
+    return rApproot
+  $logErrorS "ensureApproot" $ tshow rApproot
+  route' <- lift $ withFileDownloadTokenMaybe' source route
+  url <- approotRender rApproot route'
+  $logErrorS "ensureApprootUserGenerated" url
+  redirect url
+  
 
 -- | Simply send a `File`-Value
-sendThisFile :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId, YesodPersistRunner UniWorX) => DBFile -> HandlerFor UniWorX TypedContent
+sendThisFile :: ( YesodAuthPersist UniWorX
-sendThisFile File{..}
+                , AuthEntity UniWorX ~ User
-  | Just fileContent' <- fileContent = do
+                , AuthId UniWorX ~ UserId
-      setCSPSandbox
+                , YesodPersistRunner UniWorX
-      setContentDisposition' . Just $ takeFileName fileTitle
+                , MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey
-      let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8"
+                ) => DBFile -> HandlerFor UniWorX TypedContent
-      respondSourceDB cType $
+sendThisFile File{..} = do
-        fileContent' .| C.map toFlushBuilder
+  ensureApprootUserGeneratedMaybe' Nothing
-  | otherwise = sendResponseStatus noContent204 ()
+  if
+    | Just fileContent' <- fileContent -> do
+        setCSPSandbox
+        setContentDisposition' . Just $ takeFileName fileTitle
+        let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8"
+        respondSourceDB cType $
+          fileContent' .| C.map toFlushBuilder
+    | otherwise -> sendResponseStatus noContent204 ()
 
 sendFileReference :: forall file a.
                      ( HasFileReference file
@@ -128,6 +164,7 @@ sendFileReference :: forall file a.
                      )
                   => file -> HandlerFor UniWorX a
 sendFileReference (view (_FileReference . _1) -> fRef@FileReference{..}) = do
+  ensureApprootUserGeneratedMaybe' . Just . yield $ Left fRef
   whenIsJust fileReferenceContent $ \fRef' -> do
     dlRestr <- maybeCurrentBearerRestrictions
     case dlRestr of
@@ -146,6 +183,7 @@ serveOneFile :: forall file.
                 ) => ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
 serveOneFile source = do
   results <- runDB . runConduit $ source .| C.take 2 .| C.foldMap pure -- We don't need more than two files to make a decision below
+  ensureApprootUserGeneratedMaybe' . Just . yieldMany $ map (views (_FileReference . _1) Left) results
   case results of
     [file] -> sendFileReference file
     []     -> notFound
@@ -172,6 +210,7 @@ serveSomeFiles' :: forall file.
                    ) => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
 serveSomeFiles' archiveName source = do
   (source', results) <- runDB $ runPeekN 2 source
+  ensureApprootUserGeneratedMaybe' . Just . yieldMany $ over (traverse . _Left) (view $ _FileReference . _1) results
 
   $logDebugS "serveSomeFiles" . tshow $ length results
 

src/Handler/Utils/Table/Columns.hs

@@ -25,7 +25,6 @@ import Handler.Utils.Form
 import Handler.Utils.Widgets
 import Handler.Utils.DateTime
 import Handler.Utils.StudyFeatures
-import Handler.Utils.Download
 
 import qualified Data.CaseInsensitive as CI
 
@@ -376,7 +375,7 @@ colApplicationFiles resultInfo = Colonnade.singleton (fromSortable header) body
       | showLink
         -> flip anchorCellM (asWidgetT $ toWidget iconApplicationFiles) $ do
           cID <- encrypt appId
-          liftHandler . runDB . withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR tid ssh csh cID CAFilesR
+          return $ CApplicationR tid ssh csh cID CAFilesR
       | otherwise
         -> mempty
 

src/Handler/Workflow/Workflow/Workflow.hs

@@ -60,22 +60,6 @@ data WorkflowCurrentState = WorkflowCurrentState
 
 makePrisms ''WorkflowHistoryItemActor'
 
-data OneOrMany a = None | One a | Many
-  deriving (Eq, Ord, Read, Show, Functor, Traversable, Foldable, Generic, Typeable)
-
-instance Semigroup (OneOrMany a) where
-  None <> x = x
-  x <> None = x
-  _ <> _ = Many
-instance Monoid (OneOrMany a) where
-  mempty = None
-
-oneOrMany :: b -> (a -> b) -> b -> OneOrMany a -> b
-oneOrMany onNone onOne onMany = \case
-  None  -> onNone
-  One x -> onOne x
-  Many  -> onMany
-
 
 getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html
 getGWWWorkflowR = postGWWWorkflowR
@@ -198,13 +182,13 @@ workflowR rScope cID = do
                           <> (compareUnicode `on` userDisplayName) uA uB
                           <> comparing userIdent uA uB
                       (WFPUser{},    _           ) -> GT
-                  forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl <=< oneOrMany (return Nothing) (\fRef -> Just <$> withFileDownloadToken (yield fRef) fRoute) (Just <$> withFileDownloadTokenMaybe' Nothing fRoute)) <=< execWriterT @_ @(_, OneOrMany FileReference). forM_ payloads $ \case
+                  forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl . bool Nothing (Just fRoute) . getAny) <=< execWriterT @_ @(_, Any). forM_ payloads $ \case
-                    WorkflowFieldPayloadW (WFPText   t   ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
+                    WorkflowFieldPayloadW (WFPText   t  ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
-                    WorkflowFieldPayloadW (WFPNumber n   ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
+                    WorkflowFieldPayloadW (WFPNumber n  ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
-                    WorkflowFieldPayloadW (WFPBool   b   ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
+                    WorkflowFieldPayloadW (WFPBool   b  ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
-                    WorkflowFieldPayloadW (WFPDay    d   ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
+                    WorkflowFieldPayloadW (WFPDay    d  ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
-                    WorkflowFieldPayloadW (WFPFile   fRef) -> tell (mempty, One fRef)
+                    WorkflowFieldPayloadW (WFPFile   _  ) -> tell (mempty, Any True)
-                    WorkflowFieldPayloadW (WFPUser   uid ) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid)
+                    WorkflowFieldPayloadW (WFPUser   uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid)
             
             payloadChanges <- State.state $ \oldPayload ->
               ( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload

src/Utils/Approot.hs

@@ -1,18 +1,44 @@
 module Utils.Approot
-  ( approotScopeHost
+  ( approotScopeHost, approotScopeBaseUrl, approotScopeHost'
+  , approotRender
   ) where
 
-import ClassyPrelude
+import ClassyPrelude.Yesod hiding (Proxy)
 import Settings
 
+import Utils.Route
+
+import Network.URI (URI(URI), URIAuth(URIAuth))
 import qualified Network.URI as URI
 
 import Control.Lens
 
+import Data.Proxy
 
-approotScopeHost :: HasAppSettings site => ApprootScope -> site -> Maybe ByteString
+
-approotScopeHost rApproot app = do
+approotScopeHost' :: HasAppSettings site => (URI -> URIAuth -> a) -> ApprootScope -> site -> Maybe a
+approotScopeHost' f rApproot app = do
   approotText <- views _appRoot ($ rApproot) app
   approotURI <- URI.parseURI $ unpack approotText
   approotAuthority <- URI.uriAuthority approotURI
-  return . encodeUtf8 . pack $ URI.uriRegName approotAuthority <> URI.uriPort approotAuthority
+  return $ f approotURI approotAuthority
+
+approotScopeHost :: HasAppSettings site => ApprootScope -> site -> Maybe ByteString
+approotScopeHost = approotScopeHost' $ \_ URIAuth{..}
+  -> encodeUtf8 . pack $ uriRegName <> uriPort
+
+approotScopeBaseUrl :: HasAppSettings site => ApprootScope -> site -> Maybe Text
+approotScopeBaseUrl = approotScopeHost' $ \URI{..} URIAuth{..}
+  -> pack $ uriScheme <> "//" <> uriRegName <> uriPort
+
+approotRender :: forall url m.
+                 ( HasAppSettings (HandlerSite m)
+                 , MonadHandler m
+                 , Yesod (HandlerSite m)
+                 , HasRoute (HandlerSite m) url
+                 )
+              => ApprootScope -> url -> m Text 
+approotRender rApproot route = do
+  app <- getYesod
+  approotHost <- maybe (getApprootText approot app <$> waiRequest) return $ approotScopeBaseUrl rApproot app
+  return . yesodRender app approotHost (urlRoute route) . withLens (urlRouteParams (Proxy @(HandlerSite m))) $ \g _ -> g route

src/Utils/Route.hs

@@ -1,10 +1,13 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 module Utils.Route where
 
 import Control.Lens
-import ClassyPrelude.Yesod -- hiding (foldlM)
+import ClassyPrelude.Yesod hiding (Proxy)
 import Data.Kind (Type)
 
 import qualified Data.Map as Map
+import Data.Proxy
 
 
 class RedirectUrl site url => HasRoute site url where
@@ -46,3 +49,5 @@ instance HasRoute site (SomeRoute site) where
   type RouteWithParams site (SomeRoute site) = SomeRoute site
   urlRoute (SomeRoute url) = urlRoute url
   urlRouteParams pSite = lens (\(SomeRoute url) -> withLens (urlRouteParams pSite) $ \g _ -> g url) (\(SomeRoute url) params -> SomeRoute (urlRoute url :: Route site, params))
+instance Eq (Route site) => Eq (SomeRoute site) where
+  (==) = (==) `on` (\(SomeRoute r) -> withLens (urlRouteParams $ Proxy @site) $ \g _ -> (urlRoute r :: Route site, sort $ g r))