115 lines
4.6 KiB
Haskell
115 lines
4.6 KiB
Haskell
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 . 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
|