feat(personalised-sheet-files): finish upload functionality

TODO: Interaction of course participants with personalised files

frontend/src/utils/form/navigate-away-prompt.js

@@ -48,6 +48,10 @@ export class NavigateAwayPrompt {
       return;
     }
 
+    if (this._element.attributes.target === '_blank') {
+      return;
+    }
+
     // mark initialized
     this._element.classList.add(NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS);
   }

messages/uniworx/de-de-formal.msg

@@ -2686,6 +2686,12 @@ PersonalisedSheetFilesDownloadSurnames: Mit Nachnamen
 PersonalisedSheetFilesDownloadMatriculations: Mit Matrikelnummern
 PersonalisedSheetFilesDownloadGroups: Mit festen Abgabegruppen
 CoursePersonalisedSheetFilesArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-personalisierte_dateien
+PersonalisedSheetFilesArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-personalisierte_dateien
+PersonalisedSheetFilesMetaFilename uid@CryptoFileNameUser: meta-informationen_#{toPathPiece uid}.yaml
+PersonalisedSheetFilesDownloadAnonymousField: Anonymisierung
+PersonalisedSheetFilesDownloadAnonymousFieldTip: Soll das Archiv von personalisierten Dateien anonymisiert werden (es enthält dann keinerlei sofort persönlich identifizierende Informationen zu den Kursteilnehmern) oder sollen die Verzeichnisnamen mit einem Merkmal versehen werden und die Metainformations-Dateien zusätzlich persönliche Daten enthalten?
+PersonalisedSheetFilesIgnored count@Int64: Es #{pluralDE count "wurde" "wurden"} #{count} hochgeladene #{pluralDE count "Datei" "Dateien"} ignoriert, da sie keinem Übungsblattdatei-Typ oder keinem Kursteilnehmer zugeordnet werden #{pluralDE count "konnte" "konnten"}.
+PersonalisedSheetFilesIgnoredIntro: Es wurden die folgenden Dateien ignoriert:
 AdminCrontabNotGenerated: (Noch) keine Crontab generiert
 CronMatchAsap: ASAP
-CronMatchNone: Nie
+CronMatchNone: Nie

models/sheets.model

@@ -53,6 +53,7 @@ PersonalisedSheetFile
     content  FileContentReference Maybe
     modified UTCTime
     UniquePersonalisedSheetFile sheet user type title
+    deriving Eq Ord Read Show Generic Typeable
 
 FallbackPersonalisedSheetFilesKey
     course    CourseId

package.yaml

@@ -309,6 +309,7 @@ tests:
       - quickcheck-instances
       - generic-arbitrary
       - http-types
+      - yesod-persistent
     ghc-options:
       - -fno-warn-orphans
       - -threaded

src/Foundation/I18n.hs

@@ -16,6 +16,7 @@ module Foundation.I18n
   , ErrorResponseTitle(..)
   , UniWorXMessages(..)
   , uniworxMessages
+  , unRenderMessage, unRenderMessage', unRenderMessageLenient
   ) where
 
 import Foundation.Type
@@ -38,6 +39,11 @@ import GHC.Exts (IsList(..))
 import Yesod.Form.I18n.German
 import Yesod.Form.I18n.English
 
+import qualified Data.Foldable as F
+import qualified Data.Char as Char
+import Text.Unidecode (unidecode)
+import Data.Text.Lens (packed)
+
 
 appLanguages :: NonEmpty Lang
 appLanguages = "de-de-formal" :| ["en-eu"]
@@ -214,6 +220,8 @@ newtype SheetTypeHeader = SheetTypeHeader SheetType
 embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
 
 newtype SheetArchiveFileTypeDirectory = SheetArchiveFileTypeDirectory SheetFileType
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (Enum, Bounded, Universe, Finite)
 embedRenderMessageVariant ''UniWorX ''SheetArchiveFileTypeDirectory $ ("SheetArchiveFileTypeDirectory" <>) . concat . drop 1 . splitCamel
 
 instance RenderMessage UniWorX SheetType where
@@ -355,3 +363,19 @@ instance RenderMessage UniWorX (ValueRequired UniWorX) where
       label = mr label'
       mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
       mr = renderMessage foundation ls
+
+
+unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a]
+unRenderMessage' cmp foundation inp = nub $ do
+  l <- appLanguages'
+  x <- universeF
+  guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp
+  return x
+  where appLanguages' = F.toList appLanguages
+
+unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
+unRenderMessage = unRenderMessage' (==)
+
+unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
+unRenderMessageLenient = unRenderMessage' cmp
+  where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode)

src/Handler/Sheet/Edit.hs

@@ -98,7 +98,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
             insertSheetFile' sid SheetMarking  $ fromMaybe (return ()) sfMarkingF
             runConduit $
                  maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF)
-              .| sinkPersonalisedSheetFiles cid (Just sid) (fromMaybe False $ spffFilesKeepExisting <$> sfPersonalF)
+              .| sinkPersonalisedSheetFiles cid sid (fromMaybe False $ spffFilesKeepExisting <$> sfPersonalF)
             insert_ $ SheetEdit aid actTime sid
             addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
             -- Sanity checks generating warnings only, but not errors!

src/Handler/Sheet/Form.hs

@@ -102,9 +102,11 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
     makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm)
     makeSheetPersonalisedFilesForm template' = do
       templateDownloadMessage <- runMaybeT . hoist (liftHandler . runDB) $ do
-        Sheet{..} <- MaybeT . fmap join $ traverse get msId
+        mbSheet <- maybe (return Nothing) (fmap Just . hoistMaybe) =<< traverse (lift . get) msId
         Course{..} <- MaybeT $ get cId
-        let downloadRoute = CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR
+        let downloadRoute = case mbSheet of
+              Just Sheet{..} -> CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR
+              Nothing -> CourseR courseTerm courseSchool courseShorthand CPersonalFilesR
         guardM $ hasReadAccessTo downloadRoute
         messageIconWidget Info IconFileZip
           [whamlet|

src/Handler/Sheet/PersonalisedFiles.hs

@@ -1,16 +1,23 @@
-{-# OPTIONS_GHC -Wno-error=redundant-constraints -Wno-error=unused-top-binds -Wno-error=deprecations #-}
+{-# OPTIONS_GHC -Wno-error=redundant-constraints -Wno-error=unused-top-binds #-}
 
 module Handler.Sheet.PersonalisedFiles
   ( sinkPersonalisedSheetFiles
   , getSPersonalFilesR, getCPersonalFilesR
   , PersonalisedSheetFilesKeyException(..)
+  , sourcePersonalisedSheetFiles, resolvePersonalisedSheetFiles
+  , PersonalisedSheetFileUnresolved(..)
+  , _PSFUnresolved, _PSFUnresolvedCollatable, _PSFUnresolvedDirectory
   ) where
 
-import Import
+import Import hiding (StateT(..))
 
 import Handler.Utils
+import Handler.Sheet.PersonalisedFiles.Meta
+import Handler.Sheet.PersonalisedFiles.Types
 
 import qualified Data.Conduit.Combinators as C
+import qualified Data.Conduit.List as C (mapMaybeM)
+import Data.Conduit.ResumableSink
 
 import qualified Crypto.MAC.KMAC as Crypto
 import qualified Data.ByteArray as BA
@@ -31,50 +38,149 @@ import qualified Database.Esqueleto as E
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
+import Data.List (inits, tails)
  
 import Text.Unidecode (unidecode)
 import Data.Char (isAlphaNum)
 
-import GHC.Stack
+import qualified System.FilePath as FilePath (joinPath)
+
+import Control.Monad.Trans.State.Strict (StateT, runStateT)
+import qualified Control.Monad.State as State
+import Control.Monad.Memo (MemoStateT, MonadMemo(..), for2)
+import Utils.Memo
+
+  
+data PersonalisedSheetFileUnresolved a
+  = PSFUnresolvedDirectory a
+  | PSFUnresolvedCollatable Text a
+  | PSFUnresolved a
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+makePrisms ''PersonalisedSheetFileUnresolved
+
+
+personalisedSheetFileTypes :: [SheetFileType]
+personalisedSheetFileTypes = filter (/= SheetMarking) universeF
 
   
 resolvePersonalisedSheetFiles
-  :: forall a m.
+  :: forall m a.
      ( MonadHandler m
      , HandlerSite m ~ UniWorX
+     , MonadCatch m, MonadRandom m
      )
   => Lens' a FilePath
+  -> (a -> Bool) -- ^ @isDirectory@
   -> CourseId
-  -> Maybe SheetId
+  -> SheetId
-  -> ConduitT a (Either a (a, FileReferenceResidual PersonalisedSheetFile)) m ()
+  -> ConduitT a (Either (PersonalisedSheetFileUnresolved a) (a, FileReferenceResidual PersonalisedSheetFile)) (SqlPersistT m) ()
-resolvePersonalisedSheetFiles fpL _cid _mbsid = do
+resolvePersonalisedSheetFiles fpL isDir cid sid = do
-  C.mapM $ \fRef -> maybeT (return $ Left fRef) . fmap (Right . swap) . flip runStateT fRef . zoom fpL $ do
+  app <- getYesod
-    error "not implemented" :: StateT FilePath (MaybeT m) (FileReferenceResidual PersonalisedSheetFile)
+  C.mapM $ \fRef -> exceptT (return . Left . ($ fRef)) (return . Right . swap) . flip runStateT fRef $ do
+    let
+      genRefOptions :: ConduitT () (UserId, SheetFileType, FilePath) (StateT FilePath (ExceptT _ (SqlPersistT m))) ()
+      genRefOptions = evalMemoStateC Map.empty $
+             transPipe lift (yieldMany <=< State.gets $ resolvePersonalisedFilesDirectory app)
+          .| C.mapMaybeM (runMaybeT . filterRefOption)
+          where
+            filterRefOption :: _ -> MaybeT (MemoStateT _ _ _ (StateT FilePath (ExceptT _ (SqlPersistT m)))) (UserId, SheetFileType, FilePath)
+            filterRefOption (mbIdx, cID, sfType, fPath) = hoist (hoistStateCache $ lift . lift) $ do
+                  let
+                    getUid :: _ -> _ -> MemoStateT _ _ _ (SqlPersistT m) (Maybe UserId)
+                    getUid mbIdx' cID' = runMaybeT $ do
+                      cIDKey <- catchMPlus (Proxy @PersonalisedSheetFilesKeyException) . lift . lift $ getPersonalisedFilesKey cid (Just sid) mbIdx'
+                      uid <- either (const mzero) return . (runReaderT ?? cIDKey) $ I.decrypt cID'
+                      guardM . lift . lift $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid]
+                      return uid
+                        
+                  fmap (, sfType, fPath) . hoistMaybeM . lift $ for2 memo getUid mbIdx cID
+                  
+    mbRef <- zoom fpL . runConduit $ genRefOptions .| C.head
+    case mbRef of
+      Just (uid, sfType, fPath) -> PersonalisedSheetFileResidual sid uid sfType <$ (fpL .= fPath)
+      Nothing -> do
+        isDirectory <- State.gets isDir
+        if | isDirectory
+             -> lift $ throwE PSFUnresolvedDirectory
+           | otherwise
+             -> lift $ throwE PSFUnresolved
     
 
 sinkPersonalisedSheetFiles :: forall m.
                               ( MonadHandler m
                               , HandlerSite m ~ UniWorX
+                              , MonadCatch m, MonadRandom m
                               )
                            => CourseId
-                           -> Maybe SheetId
+                           -> SheetId
                            -> Bool -- ^ Keep existing?
                            -> ConduitT FileReference Void (SqlPersistT m) ()
-sinkPersonalisedSheetFiles cid mbsid _keep
+sinkPersonalisedSheetFiles cid sid keep
-  = resolvePersonalisedSheetFiles _fileReferenceTitle cid mbsid
+  = resolvePersonalisedSheetFiles _fileReferenceTitle (hasn't $ _fileReferenceContent . _Just) cid sid
- .| error "not implemented"
+ .| evalRWSC () Map.empty fanoutReferences >>= msgUnreferenced
+ where
+   fanoutReferences = do
+     C.mapM_ $ \case
+       Left unresolved -> tell $ Set.singleton unresolved
+       Right (fRef, residual) -> do
+         let PersonalisedSheetFileResidual{..} = residual
+             redResidual = (personalisedSheetFileResidualSheet, personalisedSheetFileResidualUser)
+         mSinks <- State.gets $ Map.lookup redResidual
+         let mkSinks
+               | Just sinks' <- mSinks
+               = Left sinks'
+               | keep
+               = Right $ \residual' -> newResumableSink $ sinkFileReferences residual'
+               | otherwise
+               = Right $ \residual' -> newResumableSink . void $ replaceFileReferences' mkFilter residual'
+             sinks = case mkSinks of
+               Left sinks' -> sinks'
+               Right mkSinks' -> Map.fromList
+                 [ (residual', mkSinks' residual')
+                 | sfType <- personalisedSheetFileTypes
+                 , let residual' = PersonalisedSheetFileResidual{ personalisedSheetFileResidualType = sfType, .. }
+                 ]
+             sink = Map.findWithDefault (error "No sink for SheetFileType") residual sinks
+         sink' <- lift $ yield fRef ++$$ sink
+         case sink' of
+           Left _ -> error "sinkFileReferences/replaceFileReferences returned prematurely"
+           Right nSink -> State.modify . Map.insert redResidual $ Map.insert residual nSink sinks
+     openSinks <- State.get
+     lift . lift . mapM_ closeResumableSink $ openSinks ^.. folded . folded
+     let (nub -> sinkSheets, nub -> sinkUsers) = unzip $ Map.keys openSinks
+     lift . lift $ deleteWhere [ PersonalisedSheetFileSheet  <-. sinkSheets
+                               , PersonalisedSheetFileUser  /<-. sinkUsers
+                               ]
+
+   msgUnreferenced ((), unreferenced) = unless (null collated && null uncollated) $
+     addMessageModal msgStatus msgTrigger $ Right msgWidget
+     where collated = Map.fromListWith (<>)
+             [ (ptn, Sum 1)
+             | PSFUnresolvedCollatable ptn _fRef <- Set.toList unreferenced
+             ]
+           collatedL = Map.toList collated
+           uncollated = [ fileReferenceTitle | PSFUnresolved FileReference{..} <- Set.toList unreferenced ]
+
+           Sum c = Sum (fromIntegral $ length uncollated) <> fold collated
+
+           msgStatus | null uncollated = Info
+                     | otherwise       = Warning
+
+           msgTrigger = i18n $ MsgPersonalisedSheetFilesIgnored c
+           msgWidget = $(widgetFile "messages/personalisedSheetFilesIgnored")
+
+   mkFilter :: FileReferenceResidual PersonalisedSheetFile -> [Filter PersonalisedSheetFile]
+   mkFilter PersonalisedSheetFileResidual{..} = [ PersonalisedSheetFileSheet ==. personalisedSheetFileResidualSheet
+                                                , PersonalisedSheetFileUser  ==. personalisedSheetFileResidualUser
+                                                , PersonalisedSheetFileType  ==. personalisedSheetFileResidualType
+                                                ]
+
+   sinkFileReferences :: FileReferenceResidual PersonalisedSheetFile -> ConduitT FileReference Void (SqlPersistT m) ()
+   sinkFileReferences residual' = C.mapM_ $ \fRef -> void . put $ _FileReference # (fRef, residual')
+           
 
 
-data PersonalisedSheetFilesDownloadAnonymous
-  = PersonalisedSheetFilesDownloadAnonymous
-  | PersonalisedSheetFilesDownloadSurnames
-  | PersonalisedSheetFilesDownloadMatriculations
-  | PersonalisedSheetFilesDownloadGroups
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-  deriving anyclass (Universe, Finite)
-nullaryPathPiece ''PersonalisedSheetFilesDownloadAnonymous $ camelToPathPiece' 4
-embedRenderMessage ''UniWorX ''PersonalisedSheetFilesDownloadAnonymous id
- 
 sourcePersonalisedSheetFiles :: forall m.
                                 ( MonadHandler m
                                 , HandlerSite m ~ UniWorX
@@ -114,9 +220,10 @@ sourcePersonalisedSheetFiles cId mbsid anonMode = do
       E.on $ E.just (courseParticipant E.^. CourseParticipantUser) E.==. personalisedSheetFile E.?. PersonalisedSheetFileUser
        E.&&. E.val mbsid E.==. personalisedSheetFile E.?. PersonalisedSheetFileSheet
       E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val cId
+      E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
       return (courseParticipant, personalisedSheetFile)
 
-    toRefs = awaitForever $ \(Entity _ CourseParticipant{..}, mbPFile) -> do
+    toRefs = awaitForever $ \(Entity _ cPart@CourseParticipant{..}, mbPFile) -> do
       MsgRenderer mr <- getMsgRenderer
       suffix <- do
         sufCache <- uses _sufCache $ Map.lookup courseParticipantUser
@@ -135,16 +242,20 @@ sourcePersonalisedSheetFiles cId mbsid anonMode = do
           , fileModified = courseParticipantRegistration
           }
         forM_ [SheetExercise, SheetHint, SheetSolution] $ \sfType ->
-           yield $ Right File
+          yield $ Right File
-            { fileTitle = dirName </> unpack (mr $ SheetArchiveFileTypeDirectory sfType)
+            { fileTitle = dirName <//> unpack (mr $ SheetArchiveFileTypeDirectory sfType)
             , fileContent = Nothing
             , fileModified = courseParticipantRegistration
             }
-        -- TODO: meta.yml
+        yieldM . fmap Right $ do
+          fileContent <- lift $ Just . toStrict <$> formatPersonalisedSheetFilesMeta anonMode cPart cID
+          let fileTitle = (dirName <//>) . ensureExtension "yaml" . unpack . mr $ MsgPersonalisedSheetFilesMetaFilename cID
+              fileModified = courseParticipantRegistration
+          return File{..}
         _dirCache %= Set.insert dirName
       whenIsJust mbPFile $ \(Entity _ pFile@PersonalisedSheetFile{..}) -> do
-        let dirName' = dirName </> unpack (mr $ SheetArchiveFileTypeDirectory personalisedSheetFileType)
+        let dirName' = dirName <//> unpack (mr $ SheetArchiveFileTypeDirectory personalisedSheetFileType)
-        yield . Left $ over (_FileReference . _1 . _fileReferenceTitle) (dirName' </>) pFile
+        yield . Left $ over (_FileReference . _1 . _fileReferenceTitle) (dirName' <//>) pFile
       where
         _sufCache :: Lens' _ _
         _sufCache = _1
@@ -167,7 +278,6 @@ newPersonalisedFilesKey :: forall m.
                            ( MonadHandler m
                            , HandlerSite m ~ UniWorX
                            , MonadThrow m, MonadRandom m
-                           , HasCallStack
                            )
                         => Either CourseId SheetId -> SqlPersistT m (Maybe Word24, CryptoIDKey)
 newPersonalisedFilesKey (Right shId) = cryptoIDKey $ \cIDKey -> fmap (Nothing,) $
@@ -178,11 +288,9 @@ newPersonalisedFilesKey (Left cId) = do
   secret <- CryptoID.genKey
   let secret' = toStrict $ Binary.encode secret
   firstN <- getRandom
-  traceM $ "newPersonalisedFilesKey: " <> prettyCallStack callStack
 
   let loop :: Word24 -> SqlPersistT m (Maybe Word24, CryptoIDKey)
       loop n = do
-        traceM "insertUnique"
         didInsert <- is _Just <$> insertUnique (FallbackPersonalisedSheetFilesKey cId n secret' now)
         if | didInsert
              -> return (Just n, secret)
@@ -195,7 +303,12 @@ newPersonalisedFilesKey (Left cId) = do
              -> loop $ succ n
    in loop firstN
 
-getPersonalisedFilesKey :: CourseId -> Maybe SheetId -> Maybe Word24 -> DB CryptoIDKey
+getPersonalisedFilesKey :: forall m.
+                           ( MonadHandler m
+                           , HandlerSite m ~ UniWorX
+                           , MonadThrow m, MonadRandom m
+                           )
+                        => CourseId -> Maybe SheetId -> Maybe Word24 -> SqlPersistT m CryptoIDKey
 getPersonalisedFilesKey _    Nothing     Nothing   = throwM PersonalisedSheetFilesKeyInsufficientContext
 getPersonalisedFilesKey _   (Just shId)  Nothing   = view _2 <$> newPersonalisedFilesKey (Right shId)
 getPersonalisedFilesKey cId  _          (Just idx) = maybeT (throwM PersonalisedSheetFilesKeyNotFound) $ do
@@ -206,15 +319,73 @@ mkPersonalisedFilesDirectory :: Maybe Word24 -> CryptoFileNameUser -> FilePath
 mkPersonalisedFilesDirectory  Nothing cID = unpack $ toPathPiece cID
 mkPersonalisedFilesDirectory (Just idx) cID = unpack $ toPathPiece cID <> "-" <> CI.foldCase (toStrict . encodeBase32Unpadded $ Binary.encode idx)
 
-resolvePersonalisedFilesDirectory :: FilePath -> [(Maybe Word24, CryptoFileNameUser)]
+resolvePersonalisedFilesDirectory :: forall master.
-resolvePersonalisedFilesDirectory = error "not implemented"
+                                     RenderMessage master SheetArchiveFileTypeDirectory
+                                  => master
+                                  -> FilePath
+                                  -> [(Maybe Word24, CryptoFileNameUser, SheetFileType, FilePath)]
+resolvePersonalisedFilesDirectory foundation (splitPath -> fPath) = do
+  (fPath', remFPath) <- inits fPath `zip` tails fPath
+  guard . not $ null remFPath
+  (SheetArchiveFileTypeDirectory sfType, fPath'') <- foldMap (\(seg, rest) -> (, rest) <$> unRenderMessageLenient foundation (pack seg)) $ foci fPath'
+  guard $ sfType `elem` personalisedSheetFileTypes
+  let cryptSegments = foldMap (filter (not . Text.null) . Text.split (flip Set.notMember cryptChars . CI.mk) . Text.pack) fPath''
+  (mIdx, cryptSegments') <- foldMap (\(inp, rest) -> (, rest) . Just <$> hoistMaybe (decodeIdx inp)) (foci cryptSegments) <|> pure (Nothing, cryptSegments)
+  cID <- foldMap (hoistMaybe . fromPathPiece) cryptSegments'
+  return (mIdx, cID, sfType, FilePath.joinPath remFPath)
+  where
+    foci :: forall a. [a] -> [(a, [a])]
+    foci [] = []
+    foci (x:xs) = (x, xs) : map (over _2 (x:)) (foci xs)
+
+    cryptoIdChars, base32Chars, cryptChars :: Set (CI Char)
+    cryptChars = base32Chars <> cryptoIdChars
+    cryptoIdChars = mappend base32Chars . Set.fromList $ map CI.mk "uwb"
+    base32Chars = Set.fromList $ map CI.mk "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"
+
+    decodeIdx :: Text -> Maybe Word24
+    decodeIdx inp
+      | Right inp' <- decodeBase32Unpadded . fromStrict $ encodeUtf8 inp
+      , Right (remInp, _, idx) <- Binary.decodeOrFail inp'
+      , null remInp
+      = Just idx
+      | otherwise = Nothing
+  
 
 
+getPersonalFilesR :: CourseId -> Maybe SheetId -> Handler TypedContent
+getPersonalFilesR cId mbsid = do
+  (Course{..}, mbSheet) <- runDB $ (,)
+    <$> get404 cId
+    <*> traverse get404 mbsid
+  
+  cRoute <- getCurrentRoute
+  ((anonRes, anonFormWdgt), anonEnctype) <- runFormGet . renderAForm FormStandard $
+    apopt (selectField optionsFinite) (fslI MsgPersonalisedSheetFilesDownloadAnonymousField & setTooltip MsgPersonalisedSheetFilesDownloadAnonymousFieldTip) (Just PersonalisedSheetFilesDownloadAnonymous)
+  
+  formResult anonRes $ \anonMode -> do
+    archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ case mbSheet of
+      Nothing -> MsgCoursePersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand
+      Just Sheet{..} -> MsgPersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand sheetName
+    sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cId mbsid anonMode
+  
+  isModal <- hasCustomHeader HeaderIsModal
+
+  fmap toTypedContent . siteLayoutMsg MsgMenuSheetPersonalisedFiles $ do
+    setTitleI MsgMenuSheetPersonalisedFiles
+    wrapForm anonFormWdgt def
+      { formMethod = GET
+      , formAction = SomeRoute <$> cRoute
+      , formEncoding = anonEnctype
+      , formAttrs = formAttrs def <> bool mempty [("uw-no-navigate-away-prompt", ""), ("target", "_blank")] isModal
+      }
+  
 getSPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
-getSPersonalFilesR = error "not implemented"
+getSPersonalFilesR tid ssh csh shn = do
+  Entity shId Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
+  getPersonalFilesR sheetCourse $ Just shId
 
 getCPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
 getCPersonalFilesR tid ssh csh = do
   cId <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-  archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCoursePersonalisedSheetFilesArchiveName tid ssh csh
+  getPersonalFilesR cId Nothing
-  serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cId Nothing PersonalisedSheetFilesDownloadAnonymous -- TODO: get Form for anonymisiation

src/Handler/Sheet/PersonalisedFiles/Meta.hs

@@ -0,0 +1,131 @@
+{-# OPTIONS_GHC -Wno-error=redundant-constraints #-}
+
+module Handler.Sheet.PersonalisedFiles.Meta
+  ( formatPersonalisedSheetFilesMeta
+  ) where
+
+import Import
+
+import Handler.Sheet.PersonalisedFiles.Types
+
+import qualified Data.Char as Char
+import qualified Data.Text as Text
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
+import qualified Data.ByteString.Lazy as Lazy.ByteString
+
+import qualified Data.YAML as YAML
+import qualified Data.YAML.Event as YAML (untagged)
+import qualified Data.YAML.Event as YAML.Event
+import qualified Data.YAML.Token as YAML (Encoding(..))
+
+import Control.Monad.Trans.State.Lazy (evalState)
+
+import qualified Database.Esqueleto as E
+
+import qualified Data.CaseInsensitive as CI
+
+  
+data PrettifyState
+  = PrettifyInitial
+  | PrettifyFlowSequence PrettifyState
+  | PrettifyBlockSequence PrettifyState
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+  
+formatPersonalisedSheetFilesMeta
+  :: ( MonadHandler m
+     , HandlerSite m ~ UniWorX
+     )
+  => PersonalisedSheetFilesDownloadAnonymous
+  -> CourseParticipant
+  -> CryptoFileNameUser
+  -> SqlPersistT m Lazy.ByteString
+formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do
+  User{..} <- getJust courseParticipantUser
+  exams <- E.select . E.from $ \(exam `E.InnerJoin` examRegistration) -> E.distinctOnOrderBy [E.asc $ exam E.^. ExamName] $ do
+    E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
+    E.where_ $ exam E.^. ExamCourse E.==. E.val courseParticipantCourse
+    E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val courseParticipantUser
+    return $ exam E.^. ExamName
+  
+  let uglyYAML = YAML.Event.writeEvents YAML.UTF8 $ concat
+        [ [ YAML.Event.StreamStart
+          , YAML.Event.DocumentStart $ YAML.Event.DirEndMarkerVersion 2
+          , YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block
+          ]
+        , mapEvents (str' "user") (str $ toPathPiece cID)
+        , guardOnM (isn't _PersonalisedSheetFilesDownloadAnonymous anonMode) $ concat
+          [ mapEvents (str' "display_name") (str userDisplayName)
+          , mapEvents (str' "surname") (str userSurname)
+          , mapEvents (str' "first_names") (str userFirstName)
+          , case userMatrikelnummer of
+              Just matr -> mapEvents (str' "matriculation") (str matr)
+              Nothing -> mzero
+          , mapEvents (str' "email") (str $ CI.original userEmail)
+          ]
+        , map flowStyle $ mapEvents (str' "languages") . YAML.Sequence () YAML.untagged $ maybe [] (views _Wrapped $ map str) userLanguages
+        , mapEvents (str' "registered_exams") . YAML.Sequence () YAML.untagged $ map (str . CI.original . E.unValue) exams
+        , [ YAML.Event.MappingEnd
+          , YAML.Event.DocumentEnd False
+          , YAML.Event.StreamEnd
+          ]
+        ]
+        where
+          str :: forall t. Textual t => t -> YAML.Node ()
+          str = YAML.Scalar () . YAML.SStr . repack
+          str' :: Text -> YAML.Node ()
+          str' = str
+
+          mapEvents :: YAML.Node () -> YAML.Node () -> [YAML.Event.Event]
+          mapEvents k v = filterEvs . nodeEvents . YAML.Mapping () YAML.untagged $ singletonMap k v
+            where filterEvs ((YAML.Event.MappingStart{} : inner) :> YAML.Event.MappingEnd) = inner
+                  filterEvs _other = error "Could not strip Mapping"
+
+          nodeEvents :: YAML.Node () -> [YAML.Event.Event]
+          nodeEvents = filterEvs . mapMaybe (fmap YAML.Event.eEvent . preview _Right) . YAML.Event.parseEvents . YAML.encodeNode . pure . YAML.Doc
+            where filterEvs = filter $ \case
+                    YAML.Event.StreamStart -> False
+                    YAML.Event.StreamEnd -> False
+                    YAML.Event.DocumentStart _ -> False
+                    YAML.Event.DocumentEnd _ -> False
+                    _other -> True
+
+          flowStyle :: YAML.Event.Event -> YAML.Event.Event
+          flowStyle = \case
+            YAML.Event.SequenceStart a t _ -> YAML.Event.SequenceStart a t YAML.Event.Flow
+            YAML.Event.MappingStart a t _ -> YAML.Event.MappingStart a t YAML.Event.Flow
+            other -> other
+
+      prettyYAML = annotate . (evalState ?? PrettifyInitial) . transduce' $ YAML.Event.parseEvents uglyYAML
+        where
+          transduce' (Left _ : _) = error "Parse error on uglyYAML"
+          transduce' (Right YAML.Event.EvPos{ eEvent, ePos = pos1 } : es@(Right YAML.Event.EvPos{ ePos = pos2 }: _))
+            = (:) <$> ((YAML.Event.posByteOffset pos1, YAML.Event.posByteOffset pos2, ) <$> state (`transduce` eEvent)) <*> transduce' es
+          transduce' (Right YAML.Event.EvPos{..} : es)
+            = (:) <$> ((YAML.Event.posByteOffset ePos, fromIntegral $ Lazy.ByteString.length uglyYAML, ) <$> state (`transduce` eEvent)) <*> transduce' es
+          transduce' [] = return []
+
+          annotate = fst . foldl' annotate' (uglyYAML, Lazy.ByteString.length uglyYAML) . reverse
+            where annotate' (dat, mLength) (fromIntegral -> pos1, fromIntegral -> pos2, (fromStrict . encodeUtf8 -> ann1, ann3, ann2))
+                    = let (before', after) = Lazy.ByteString.splitAt pos2' dat
+                          (before, event) = Lazy.ByteString.splitAt pos1' before'
+                          event' = decodeUtf8 $ toStrict event
+                          ws = Text.takeWhileEnd Char.isSpace event'
+                          event'' = Text.dropWhileEnd Char.isSpace event'
+                          pos1' = min pos1 mLength
+                          pos2' = min pos2 mLength
+                       in (before <> ann1 <> fromStrict (encodeUtf8 $ ann3 event'') <> fromStrict (encodeUtf8 $ ann2 ws) <> after, pos1')
+
+          transduce :: PrettifyState -> YAML.Event.Event -> ((Text, Text -> Text, Text -> Text), PrettifyState)
+          transduce cState (YAML.Event.SequenceStart _ _ YAML.Event.Flow) = ((mempty, id, bool " " mempty . null), PrettifyFlowSequence cState)
+          transduce (PrettifyFlowSequence pState) YAML.Event.SequenceEnd = ((mempty, id, id), pState)
+          transduce cState@(PrettifyFlowSequence _) _ = ((mempty, f, bool " " mempty . null), cState)
+            where f str | ']' `elem` str = filter (/= '\n') str
+                        | otherwise = str
+          -- transduce PrettifyInitial _ = ((mempty, id), PrettifyInitial)
+          transduce cState (YAML.Event.SequenceStart _ _ YAML.Event.Block) = (("  ", id, id), PrettifyBlockSequence cState)
+          transduce (PrettifyBlockSequence pState) YAML.Event.SequenceEnd = ((mempty, id, id), pState)
+          transduce cState@(PrettifyBlockSequence _) _ = ((mempty, Text.replace "\n-" "\n  -", id), cState)
+          transduce cState _ = ((mempty, id, id), cState)
+          -- transduce cState _ = (("<", id, \ws -> "|" <> ws <> ">"), cState) -- TODO
+  return prettyYAML

src/Handler/Sheet/PersonalisedFiles/Types.hs

@@ -0,0 +1,19 @@
+module Handler.Sheet.PersonalisedFiles.Types
+  ( PersonalisedSheetFilesDownloadAnonymous(..)
+  , _PersonalisedSheetFilesDownloadAnonymous, _PersonalisedSheetFilesDownloadSurnames, _PersonalisedSheetFilesDownloadMatriculations, _PersonalisedSheetFilesDownloadGroups
+  ) where
+
+import Import
+
+
+data PersonalisedSheetFilesDownloadAnonymous
+  = PersonalisedSheetFilesDownloadAnonymous
+  | PersonalisedSheetFilesDownloadSurnames
+  | PersonalisedSheetFilesDownloadMatriculations
+  | PersonalisedSheetFilesDownloadGroups
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+nullaryPathPiece ''PersonalisedSheetFilesDownloadAnonymous $ camelToPathPiece' 4
+embedRenderMessage ''UniWorX ''PersonalisedSheetFilesDownloadAnonymous id
+
+makePrisms ''PersonalisedSheetFilesDownloadAnonymous

src/Handler/Utils/Rating.hs

@@ -101,7 +101,6 @@ ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
     fileTitle = ensureExtension extensionRating . unpack . mr $ MsgRatingFileTitle cID
     fileContent = Just . Lazy.ByteString.toStrict $ formatRating mr' dtFmt cID rating
   return File{..}
-  where ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName
 
 type SubmissionContent = Either FileReference (SubmissionId, Rating')
 
@@ -162,4 +161,3 @@ isRatingFile (takeFileName -> fName) = liftHandler . runMaybeT $ do
       let canonExtension = Set.singleton $ CI.mk (pack extensionRating)
           validExtensions = foldMap (Set.map CI.mk . mimeExtensions) ["application/json", "text/vnd.yaml"]
       guard $ extension `Set.member` Set.union canonExtension validExtensions
-      where ensureExtension ext fName' = bool (`addExtension` ext) id (ext `isExtensionOf` fName') fName'

src/Handler/Utils/Table/Pagination.hs

@@ -1094,7 +1094,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       | Just DBTCsvEncode{..} <- dbtCsvEncode
       , Just exportData <- fromDynamic dbCsvExportData -> do
         hdr <- dbtCsvHeader $ Just exportData
-        let ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName
         dbtCsvName' <- timestampCsv <*> pure dbtCsvName
         setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName'
         sendResponse <=< liftHandler . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave

src/Model.hs

@@ -57,6 +57,7 @@ instance ToMessage (Key Term) where
 instance HasFileReference CourseApplicationFile where
   newtype FileReferenceResidual CourseApplicationFile
     = CourseApplicationFileResidual { courseApplicationFileResidualApplication :: CourseApplicationId }
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
   _FileReference
     = iso (\CourseApplicationFile{..} -> ( FileReference
@@ -84,6 +85,7 @@ instance HasFileReference CourseApplicationFile where
 instance HasFileReference CourseAppInstructionFile where
   newtype FileReferenceResidual CourseAppInstructionFile
     = CourseAppInstructionFileResidual { courseAppInstructionFileResidualCourse :: CourseId }
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
   _FileReference
     = iso (\CourseAppInstructionFile{..} -> ( FileReference
@@ -112,7 +114,7 @@ instance HasFileReference SheetFile where
   data FileReferenceResidual SheetFile = SheetFileResidual
     { sheetFileResidualSheet :: SheetId
     , sheetFileResidualType :: SheetFileType
-    }
+    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
   _FileReference
     = iso (\SheetFile{..} -> ( FileReference
@@ -146,7 +148,7 @@ instance HasFileReference PersonalisedSheetFile where
     { personalisedSheetFileResidualSheet :: SheetId
     , personalisedSheetFileResidualUser :: UserId
     , personalisedSheetFileResidualType :: SheetFileType
-    }
+    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
   _FileReference
     = iso (\PersonalisedSheetFile{..} -> ( FileReference
@@ -182,7 +184,7 @@ instance HasFileReference SubmissionFile where
     { submissionFileResidualSubmission :: SubmissionId
     , submissionFileResidualIsUpdate
     , submissionFileResidualIsDeletion :: Bool
-    }
+    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
   _FileReference
     = iso (\SubmissionFile{..} -> ( FileReference
@@ -216,6 +218,7 @@ instance HasFileReference SubmissionFile where
 instance HasFileReference CourseNewsFile where
   newtype FileReferenceResidual CourseNewsFile
     = CourseNewsFileResidual { courseNewsFileResidualNews :: CourseNewsId }
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
   _FileReference
     = iso (\CourseNewsFile{..} -> ( FileReference
@@ -241,9 +244,9 @@ instance HasFileReference CourseNewsFile where
   fileReferenceModifiedField = CourseNewsFileModified
 
 instance HasFileReference MaterialFile where
-  data FileReferenceResidual MaterialFile = MaterialFileResidual
+  newtype FileReferenceResidual MaterialFile
-    { materialFileResidualMaterial :: MaterialId
+    = MaterialFileResidual { materialFileResidualMaterial :: MaterialId }
-    }
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
   _FileReference
     = iso (\MaterialFile{..} -> ( FileReference

src/Utils.hs

@@ -109,6 +109,9 @@ import qualified Data.Text.Lazy.Builder as Builder
 
 import Unsafe.Coerce
 
+import System.FilePath as Utils (addExtension, isExtensionOf)
+import System.FilePath (dropDrive)
+
 {-# ANN module ("HLint: ignore Use asum" :: String) #-}
 
 
@@ -440,6 +443,23 @@ dropWhileM p xs'
   = bool (return xs') (dropWhileM p xs) =<< p x
   | otherwise = return xs'
 
+
+isSubsequenceOfBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+isSubsequenceOfBy _   []       _     = True
+isSubsequenceOfBy _   _        []    = False
+isSubsequenceOfBy cmp a@(x:a') (y:b)
+  | x `cmp` y = isSubsequenceOfBy cmp a' b
+  | otherwise = isSubsequenceOfBy cmp a  b
+
+withoutSubsequenceBy :: (a -> b -> Bool) -> [a] -> [b] -> Maybe [b]
+withoutSubsequenceBy cmp = go []
+  where go acc []       b     = Just $ reverse acc ++ b
+        go _   _        []    = Nothing
+        go acc a@(x:a') (y:b)
+          | x `cmp` y = go acc a' b
+          | otherwise = go (y:acc) a b
+        
+
 ----------
 -- Sets --
 ----------
@@ -1192,3 +1212,15 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON
 
       parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
       parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx
+
+--------------
+-- FilePath --
+--------------
+
+ensureExtension :: String -> FilePath -> FilePath
+ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName
+
+infixr 4 <//>
+
+(<//>) :: FilePath -> FilePath -> FilePath
+dir <//> file = dir </> dropDrive file

src/Utils/Files.hs

@@ -2,7 +2,7 @@ module Utils.Files
   ( sinkFile, sinkFiles
   , sinkFile', sinkFiles'
   , FileUploads
-  , replaceFileReferences
+  , replaceFileReferences, replaceFileReferences'
   ) where
 
 import Import.NoFoundation
@@ -19,7 +19,6 @@ import qualified Data.ByteArray as ByteArray
 
 import qualified Data.Map.Lazy as Map
 import qualified Data.Set as Set
-import Control.Monad.Trans.State.Lazy (execStateT)
 import Control.Monad.State.Class (modify)
 
 import Database.Persist.Sql (deleteWhereCount)
@@ -81,19 +80,17 @@ sinkFile' file residual = do
 
 type FileUploads = ConduitT () FileReference (HandlerFor UniWorX) ()
 
-replaceFileReferences :: ( MonadHandler m, MonadThrow m
+replaceFileReferences' :: ( MonadIO m, MonadThrow m
-                         , HandlerSite m ~ UniWorX
+                          , HasFileReference record
-                         , HasFileReference record
+                          , PersistEntityBackend record ~ SqlBackend
-                         , PersistEntityBackend record ~ SqlBackend
+                          )
-                         )
+                       => (FileReferenceResidual record -> [Filter record])
-                      => (FileReferenceResidual record -> [Filter record])
+                       -> FileReferenceResidual record
-                      -> FileReferenceResidual record
+                       -> ConduitT FileReference Void (SqlPersistT m) (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@
-                      -> FileUploads
+replaceFileReferences' mkFilter residual = do
-                      -> SqlPersistT m (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@
-replaceFileReferences mkFilter residual fs = do
   let resFilter = mkFilter residual
 
-  oldFiles <- Map.fromListWith Set.union . map (\(Entity k v) -> (v ^. _FileReference . _1, Set.singleton k)) <$> selectList resFilter []
+  oldFiles <- lift $ Map.fromListWith Set.union . map (\(Entity k v) -> (v ^. _FileReference . _1, Set.singleton k)) <$> selectList resFilter []
   let oldFiles' = setOf (folded . folded) oldFiles
 
   let
@@ -111,8 +108,19 @@ replaceFileReferences mkFilter residual fs = do
           fId <- lift $ insert fRef'
           modify $ Map.alter (Just . maybe (Set.singleton fId) (Set.insert fId)) fRef
 
-  changes <- fmap (setOf $ folded . folded) . flip execStateT oldFiles . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert
+  changes <- fmap (setOf $ folded . folded) . execStateC oldFiles $ C.mapM_ finsert
 
-  deleteWhere $ resFilter <> [ persistIdField <-. Set.toList (oldFiles' `Set.intersection` changes) ]
+  lift . deleteWhere $ resFilter <> [ persistIdField <-. Set.toList (oldFiles' `Set.intersection` changes) ]
 
   return (oldFiles', changes)
+
+replaceFileReferences :: ( MonadHandler m, MonadThrow m
+                         , HandlerSite m ~ UniWorX
+                         , HasFileReference record
+                         , PersistEntityBackend record ~ SqlBackend
+                         )
+                      => (FileReferenceResidual record -> [Filter record])
+                      -> FileReferenceResidual record
+                      -> FileUploads
+                      -> SqlPersistT m (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@
+replaceFileReferences mkFilter residual fs = runConduit $ transPipe liftHandler fs .| replaceFileReferences' mkFilter residual

src/Utils/Memo.hs

@@ -0,0 +1,25 @@
+module Utils.Memo
+  ( evalMemoStateC
+  ) where
+
+import ClassyPrelude
+import Data.Conduit
+import Data.Conduit.Lift (evalStateC)
+
+import Control.Monad.Memo
+import Control.Monad.Trans.State.Strict (StateT)
+import qualified Control.Monad.State.Class as State
+
+
+evalMemoStateC :: forall m s k v i o r.
+                  Monad m
+               => s -> ConduitT i o (MemoStateT s k v m) r -> ConduitT i o m r
+evalMemoStateC initSt = evalStateC initSt . transPipe runMemoStateT'
+  where
+    runMemoStateT' :: forall a.
+                      MemoStateT s k v m a
+                   -> StateT s m a
+    runMemoStateT' act = do
+          cache <- State.get
+          (res, cache') <- lift $ runMemoStateT act cache
+          res <$ State.put cache'

templates/messages/personalisedSheetFilesIgnored.hamlet

@@ -0,0 +1,9 @@
+$newline never
+_{MsgPersonalisedSheetFilesIgnoredIntro}
+<ul>
+  $forall fPath <- uncollated
+    <li>
+      #{fPath}
+  $forall (ptn, Sum count) <- toList collatedL
+    <li>
+      #{count} × #{ptn}

test/Handler/Sheet/PersonalisedFilesSpec.hs

@@ -0,0 +1,114 @@
+module Handler.Sheet.PersonalisedFilesSpec where
+
+import TestImport
+
+import Utils.Files
+import Handler.Sheet.PersonalisedFiles
+import Handler.Sheet.PersonalisedFiles.Types
+
+import qualified Yesod.Persist as Yesod
+
+import ModelSpec ()
+
+import Data.Universe.Class
+
+import Data.Conduit
+import qualified Data.Conduit.Combinators as C
+import Control.Lens.Extras
+import Control.Monad.Trans.Maybe
+  
+import qualified Crypto.Hash as Crypto (hash)
+
+import System.FilePath (dropDrive)
+
+import Data.Time.Clock (diffUTCTime)
+import Data.Char (chr)
+
+import Database.Persist.Sql (transactionUndo)
+
+
+instance Arbitrary (FileReferenceResidual PersonalisedSheetFile) where
+  arbitrary = PersonalisedSheetFileResidual
+    <$> arbitrary
+    <*> arbitrary
+    <*> elements [ sfType | sfType <- universeF, sfType /= SheetMarking ]
+
+instance Arbitrary PersonalisedSheetFilesDownloadAnonymous where
+  arbitrary = elements universeF
+
+
+spec :: Spec
+spec = withApp . focus . describe "Personalised sheet file zip encoding" $ do
+  it "roundtrips" . replicateM_ 10 . runHandler . Yesod.runDB $ do
+    term <- liftIO $ generate arbitrary
+    tid <- insert term
+    school <- liftIO $ generate arbitrary
+    ssh <- insert school
+    course <- liftIO $ generate arbitrary <&> \c -> c { courseTerm = tid, courseSchool = ssh }
+    cid <- insert course
+    sheet <- liftIO $ generate arbitrary <&> \s -> s { sheetCourse = cid }
+    shid <- insert sheet
+
+    sheetFiles' <- liftIO . generate . listOf $ scale (`div` 2) arbitrary
+    sheetFiles <- fmap catMaybes . forM sheetFiles' $ \(f', res') -> runMaybeT $ do
+      let f = f' { fileTitle = filter (/= chr 0) $ fileTitle f' } -- PostgreSQL doesn't like to store NUL-bytes in text
+      guard . not . null . dropDrive $ fileTitle f
+      
+      uid <-
+        let userLoop = do
+              user <- liftIO $ generate arbitrary
+              lift (insertUnique user) >>= maybe userLoop return
+         in userLoop
+      let res = res' { personalisedSheetFileResidualSheet = shid, personalisedSheetFileResidualUser = uid }
+      fRef <- lift (sinkFile f :: DB FileReference)
+      now <- liftIO getCurrentTime
+      void . lift . insert $ CourseParticipant cid (personalisedSheetFileResidualUser res) now Nothing Nothing CourseParticipantActive
+      void . lift . insert $ _FileReference # (fRef, res)
+      return (f, res)
+
+    anonMode <- liftIO $ generate arbitrary
+
+    let
+      fpL :: Lens' (Either PersonalisedSheetFile File) FilePath
+      fpL = lens (either personalisedSheetFileTitle fileTitle) $ \f' path -> case f' of
+        Left pf -> Left pf { personalisedSheetFileTitle = path }
+        Right f -> Right f { fileTitle = path }
+      isDirectory = either (is _Nothing . personalisedSheetFileContent) (is _Nothing . fileContent)
+
+    recoveredFiles <- runConduit $
+         sourcePersonalisedSheetFiles cid (Just shid) anonMode
+      .| resolvePersonalisedSheetFiles fpL isDirectory cid shid
+      .| C.foldMap pure
+
+    let
+      checkFile :: Either (PersonalisedSheetFileUnresolved (Either PersonalisedSheetFile File)) (Either PersonalisedSheetFile File, FileReferenceResidual PersonalisedSheetFile)
+                -> (File, FileReferenceResidual PersonalisedSheetFile)
+                -> Bool
+      checkFile (Left _) _
+        = False
+      checkFile (Right (recFile, recResidual)) (file, residual)
+        =    recResidual == residual
+          && case recFile of
+               Right f -> file == f
+               Left pf ->    dropDrive (fileTitle file) == dropDrive (personalisedSheetFileTitle pf)
+                          && abs (fileModified file `diffUTCTime` personalisedSheetFileModified pf) < 1e-6 -- Precision is a PostgreSQL limitation
+                          && fmap Crypto.hash (fileContent file) == personalisedSheetFileContent pf
+
+      errors = go [] sheetFiles recoveredFiles
+        where go acc xs [] = reverse acc ++ map Left xs
+              go acc [] ys = reverse acc ++ map Right ys
+              go acc xs (y:ys)
+                | (xs', _ : xs'') <- break (checkFile y) xs
+                = go acc (xs' ++ xs'') ys
+                | is (_Left . _PSFUnresolved) y
+                , fromMaybe False $ previews (_Left . _PSFUnresolved . _Right . _fileTitle) ("meta-informationen" `isInfixOf`) y -- DEBUG; remove once _PSFUnresolvedCollatable works
+                = go acc xs ys
+                | isn't (_Left . _PSFUnresolved) y
+                , isn't _Right y
+                = go acc xs ys
+                | otherwise       = go (Right y : acc) xs ys
+
+    unless (null errors) . liftIO $ 
+      expectationFailure $ show recoveredFiles ++ " does not match " ++ show sheetFiles ++ ": " ++ show errors
+
+    transactionUndo