diff --git a/models b/models index 6a73f6296..38705f488 100644 --- a/models +++ b/models @@ -32,7 +32,7 @@ Course description Html Maybe linkExternal Text Maybe shorthand Text - termId TermIdentifier + termId TermId schoolId SchoolId capacity Int Maybe created UTCTime @@ -54,13 +54,7 @@ CourseParticipant Sheet courseId CourseId name Text - sheetType SheetType - maxPoints Double Maybe - requiredPoints Double Maybe - exerciseId FileId Maybe - hintId FileId Maybe - solutionId FileId Maybe - markingId FileId Maybe + type SheetType markingText Text Maybe activeFrom UTCTime activeTo UTCTime @@ -70,18 +64,20 @@ Sheet changed UTCTime createdBy UserId changedBy UserId +SheetFile + sheetId SheetId + fileId FileId + type SheetFileType + UniqueSheetFile fileId sheetId type File - title Text - content ByteString - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId + title FilePath + content ByteString Maybe -- Nothing iff this is a directory + modified UTCTime + deriving Show Eq Submission sheetId SheetId - updateId FileId Maybe ratingBy UserId Maybe - ratingPoints Double Maybe + ratingPoints Points Maybe ratingComment Text Maybe rated UTCTime Maybe created UTCTime @@ -91,7 +87,8 @@ Submission SubmissionFile submissionId SubmissionId fileId FileId - UniqueSubmissionFile fileId submissionId + isUpdate Bool + UniqueSubmissionFile fileId submissionId isUpdate SubmissionUser userId UserId submissionId SubmissionId @@ -115,7 +112,7 @@ TutorialUser tutorialId TutorialId UniqueTutorialUser userId tutorialId Booking - termId TermIdentifier + termId TermId begin UTCTime end UTCTime weekly Bool diff --git a/package.yaml b/package.yaml index 190bfb3d7..9ef1ecd1b 100644 --- a/package.yaml +++ b/package.yaml @@ -54,6 +54,10 @@ dependencies: - colonnade >=1.1.1 - yesod-colonnade >=1.1.0 - blaze-markup +- zip-stream +- filepath +- transformers +- wl-pprint-text # The library contains all of our application code. The executable # defined below is just a thin wrapper. @@ -100,6 +104,8 @@ tests: - hspec >=2.0.0 - QuickCheck - yesod-test + - conduit-extra + - quickcheck-instances # Define flags used by "yesod devel" to make compilation faster flags: diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e674b4185..0834adfbc 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -27,7 +27,7 @@ getCourseShowTermR :: TermIdentifier -> Handler Html getCourseShowTermR tidini = do (term,courses) <- runDB $ do term <- get $ TermKey tidini - courses <- selectList [CourseTermId ==. tidini] [Asc CourseShorthand] + courses <- selectList [CourseTermId ==. TermKey tidini] [Asc CourseShorthand] return (term, courses) when (isNothing term) $ do setMessage [shamlet| Semester #{termToText tidini} nicht gefunden. |] @@ -35,7 +35,7 @@ getCourseShowTermR tidini = do let colonnadeTerms = mconcat [ headed "Kürzel" $ (\c -> let shd = courseShorthand c - tid = courseTermId c + (TermKey tid) = courseTermId c in do adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False [whamlet| @@ -64,7 +64,7 @@ postCourseEditR = courseEditHandler Nothing getCourseEditExistR :: TermIdentifier -> Text -> Handler Html getCourseEditExistR tid csh = do - course <- runDB $ getBy $ CourseTermShort tid csh + course <- runDB $ getBy $ CourseTermShort (TermKey tid) csh courseEditHandler course @@ -73,8 +73,8 @@ courseEditHandler course = do aid <- requireAuthId ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course action <- lookupPostParam "formaction" - liftIO $ putStrLn "================" - liftIO $ print (result,action) + liftIO $ putStrLn "================" -- DEBUG + liftIO $ print (result,action) -- DEBUG case (result,action) of (FormSuccess res, fAct) | fAct == formActionDelete @@ -109,7 +109,7 @@ courseEditHandler course = do , courseDescription = cfDesc res , courseLinkExternal = cfLink res , courseShorthand = cfShort res - , courseTermId = cfTerm res + , courseTermId = TermKey $ cfTerm res , courseSchoolId = cfSchool res , courseCapacity = cfCapacity res , courseRegisterFrom = cfRegFrom res @@ -165,7 +165,7 @@ courseToForm cEntity = CourseForm , cfDesc = courseDescription course , cfLink = courseLinkExternal course , cfShort = courseShorthand course - , cfTerm = courseTermId course + , cfTerm = unTermKey $ courseTermId course , cfSchool = courseSchoolId course , cfCapacity = courseCapacity course , cfRegFrom = courseRegisterFrom course @@ -188,8 +188,8 @@ newCourseForm template html = do <*> aopt utcTimeField (set "Anmeldung von:") (cfRegFrom <$> template) <*> aopt utcTimeField (set "Anmeldung bis:") (cfRegTo <$> template) -- <* bootstrapSubmit (bsSubmit (show cid)) - liftIO $ putStrLn "++++++++++" - liftIO $ print cid + liftIO $ putStrLn "++++++++++" -- DEBUG + liftIO $ print cid -- DEBUG return $ case result of FormSuccess courseResult | errorMsgs <- validateCourse courseResult diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 188a32e42..f97d51547 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -39,7 +39,7 @@ getTermShowR = do , headed "Aktiv" (\t -> if termActive t then tickmark else "") -- , Colonnade.bool (Headed "Aktiv") termActive (const tickmark) (const "") , headed "Kursliste" $ (\t -> let tn = termName t in do - numCourses <- handlerToWidget $ runDB $ count [CourseTermId ==. tn ] + numCourses <- handlerToWidget $ runDB $ count [CourseTermId ==. TermKey tn ] [whamlet| #{show numCourses} Kurse diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs new file mode 100644 index 000000000..4afcb8386 --- /dev/null +++ b/src/Handler/Utils/Zip.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Utils.Zip + ( ZipError(..) + , ZipInfo(..) + , produceZip + , consumeZip + ) where + +import Import + +import qualified Data.Conduit.List as Conduit (map) + +import Codec.Archive.Zip.Conduit.Types +import Codec.Archive.Zip.Conduit.UnZip +import Codec.Archive.Zip.Conduit.Zip + +-- import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as Lazy.ByteString + +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import System.FilePath +import Data.Time + +import Data.List (dropWhileEnd) + + +instance Default ZipInfo where + def = ZipInfo + { zipComment = mempty + } + + +consumeZip :: ( MonadBase b m + , PrimMonad b + , MonadThrow m + ) => ConduitM ByteString File m ZipInfo +consumeZip = unZipStream `fuseUpstream` consumeZip' + where + consumeZip' :: ( MonadThrow m + ) => Conduit (Either ZipEntry ByteString) m File + consumeZip' = do + input <- await + case input of + Nothing -> return () + Just (Right _) -> throw $ userError "Data chunk in unexpected place when parsing ZIP" + Just (Left e) -> do + zipEntryName' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ zipEntryName e + contentChunks <- toConsumer accContents + let + fileTitle = normalise $ makeValid zipEntryName' + fileModified = localTimeToUTC utc $ zipEntryTime e + fileContent + | hasTrailingPathSeparator zipEntryName' = Nothing + | otherwise = Just $ mconcat contentChunks + yield $ File{..} + consumeZip' + accContents :: Monad m => Sink (Either a b) m [b] + accContents = do + input <- await + case input of + Just (Right x) -> (x :) <$> accContents + Just (Left x) -> [] <$ leftover (Left x) + _ -> return [] + +produceZip :: ( MonadBase b m + , PrimMonad b + , MonadThrow m + ) => ZipInfo + -> Conduit File m ByteString +produceZip info = Conduit.map toZipData =$= void (zipStream zipOptions) + where + zipOptions = ZipOptions + { zipOpt64 = True + , zipOptCompressLevel = -1 -- This is passed through all the way to the C zlib, where it means "default level" + , zipOptInfo = info + } + + toZipData :: Monad m => File -> (ZipEntry, ZipData m) + toZipData f@(File{..}) = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent) + + toZipEntry :: File -> ZipEntry + toZipEntry File{..} = ZipEntry + { zipEntryName = Text.encodeUtf8 . Text.pack . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ fileTitle + , zipEntryTime = utcToLocalTime utc fileModified + } + where + isDir = isNothing fileContent diff --git a/src/Handler/Utils/Zip/Rating.hs b/src/Handler/Utils/Zip/Rating.hs new file mode 100644 index 000000000..535d54014 --- /dev/null +++ b/src/Handler/Utils/Zip/Rating.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Handler.Utils.Zip.Rating + ( Rating(..) + , getRating + , formatRating + , RatingException(..) + , UnicodeException(..) + , parseRating + , extractRatings + ) where + +import Import hiding (()) + +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +import Control.Monad.Trans.Maybe + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Text.Encoding.Error (UnicodeException(..)) + +import qualified Data.Text.Lazy.Encoding as Lazy.Text + +import qualified Data.ByteString.Lazy as Lazy (ByteString) + +import Text.Read (readEither) + +import GHC.Generics (Generic) +import Data.Typeable (Typeable) + + +instance HasResolution prec => Pretty (Fixed prec) where + pretty = pretty . show + + +data Rating = Rating + { ratingCourseName :: Text + , ratingSheetName :: Text + , ratingSubmissionId :: SubmissionId + , ratingComment :: Maybe Text + , ratingPoints :: Maybe Points + } deriving (Read, Show, Eq, Generic, Typeable) + +type Rating' = ( Maybe Points + , Maybe Text -- ^ Rating comment + ) + +data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode + | RatingMissingSeparator -- ^ Could not split rating header from comments + | RatingMultiple -- ^ Encountered multiple point values in rating + | RatingInvalid String -- ^ Failed to parse rating point value + deriving (Show, Eq, Generic, Typeable) + +instance Exception RatingException + + +getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating) +getRating ratingSubmissionId = runMaybeT $ do + Submission{ submissionSheetId, submissionRatingComment = ratingComment, submissionRatingPoints = ratingPoints } <- MaybeT $ get ratingSubmissionId + Sheet{ sheetCourseId, sheetName = ratingSheetName } <- MaybeT $ get submissionSheetId + Course{ courseName = ratingCourseName } <- MaybeT $ get sheetCourseId + return Rating{..} + +formatRating :: Rating -> Lazy.ByteString +formatRating Rating{..} = let + doc = renderPretty 1 45 $ foldr (<$$>) mempty + [ "= Bitte nur Bewertung und Kommentare ändern =" + , "=============================================" + , "========== UniWorx Bewertungsdatei ==========" + , "======= diese Datei ist UTF8 encodiert ======" + , "Informationen zum Übungsblatt:" + , indent 2 $ foldr (<$$>) mempty + [ "Veranstaltung:" <+> pretty ratingCourseName + , "Blatt:" <+> pretty ratingSheetName + ] + , "Abgabe-Id:" <+> pretty (show ratingSubmissionId) -- FIXME + , "=============================================" + , "Bewertung:" <+> pretty ratingPoints + , "=========== Beginn der Kommentare ===========" + , pretty ratingComment + ] + in Lazy.Text.encodeUtf8 $ displayT doc + +parseRating :: MonadThrow m => ByteString -> m Rating' +parseRating input = do + inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input + let + (headerLines, commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText + ratingLines = filter (rating `Text.isInfixOf`) headerLines + sep = "Beginn der Kommentare" + rating = "Bewertung:" + comment' <- case commentLines of + (_:commentLines') -> return . Text.strip $ Text.unlines commentLines' + _ -> throw RatingMissingSeparator + let + comment + | Text.null comment' = Nothing + | otherwise = Just comment' + ratingLine' <- case ratingLines of + [l] -> return l + _ -> throw RatingMultiple + let + (_, ratingLine) = Text.breakOnEnd rating ratingLine' + ratingStr = Text.unpack $ Text.strip ratingLine + rating <- case () of + _ | null ratingStr -> return Nothing + | otherwise -> either (throw . RatingInvalid) return $ Just <$> readEither ratingStr + return (rating, comment) + + +extractRatings :: MonadThrow m => (FilePath -> Maybe SubmissionId) -> Conduit File m (Either File (SubmissionId, Rating')) +extractRatings isRating = void . runMaybeT $ do + f@(File{..}) <- MaybeT await + + lift $ case () of + _ | Just sId <- isRating fileTitle + , Just content' <- fileContent + -> yieldM $ Right . (sId, ) <$> parseRating content' + | otherwise -> yield $ Left f diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 9ca93f2a7..cf17f5064 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -10,3 +10,5 @@ import Settings.StaticFiles as Import import Yesod.Auth as Import import Yesod.Core.Types as Import (loggerSet) import Yesod.Default.Config2 as Import + +import Data.Fixed as Import diff --git a/src/Model/Types.hs b/src/Model/Types.hs index e887a515e..08856e56a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -8,6 +8,8 @@ module Model.Types where import ClassyPrelude +import Data.Fixed + import Common import Database.Persist.TH @@ -26,19 +28,31 @@ import qualified Data.CaseInsensitive as CI import Yesod.Core.Dispatch (PathPiece(..)) import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..)) +import Data.Aeson.TH (deriveJSON, defaultOptions) import GHC.Generics (Generic) import Data.Typeable (Typeable) -data SheetType = Regular | Bonus | Extra - deriving (Show, Read, Eq, Ord, Enum, Bounded) -derivePersistField "SheetType" +type Points = Centi + +data SheetType + = Bonus { maxPoints :: Points } + | Normal { maxPoints :: Points } + | Pass { maxPoints, passingPoints :: Points } + | NotGraded + deriving (Show, Read, Eq) +deriveJSON defaultOptions ''SheetType +derivePersistFieldJSON "SheetType" data ExamStatus = Attended | NoShow | Voided deriving (Show, Read, Eq, Ord, Enum, Bounded) derivePersistField "ExamStatus" +data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking + deriving (Show, Read, Eq, Ord, Enum, Bounded) +derivePersistField "SheetFileType" + data Season = Summer | Winter deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) diff --git a/stack.yaml b/stack.yaml index 1e1790f3f..ab4813dbb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,4 +9,5 @@ packages: extra-deps: - colonnade-1.1.1 - yesod-colonnade-1.1.0 +- zip-stream-0.1.0.1 resolver: lts-9.3 diff --git a/test/Handler/Utils/Zip/RatingSpec.hs b/test/Handler/Utils/Zip/RatingSpec.hs new file mode 100644 index 000000000..dc26958c4 --- /dev/null +++ b/test/Handler/Utils/Zip/RatingSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Utils.Zip.RatingSpec where + +import TestImport + +import Handler.Utils.Zip.Rating + +import qualified Data.ByteString.Lazy as Lazy.ByteString + +import qualified Data.Text as Text + +import Database.Persist.Class +import Database.Persist.Sql + + +instance Arbitrary Rating where + arbitrary = do + ratingCourseName <- arbitrary + ratingSheetName <- arbitrary + ratingSubmissionId <- SubmissionKey . SqlBackendKey <$> arbitrary + ratingComment <- (fmap Text.strip <$> arbitrary) `suchThat` maybe True (not . Text.null) + ratingPoints <- arbitrary + return Rating{..} + + +spec :: Spec +spec = describe "Rating files" $ do + it "have compatible formatting/parsing" . property $ + \rating@(Rating{..}) -> parseRating (Lazy.ByteString.toStrict $ formatRating rating) >>= (`shouldBe` (ratingPoints, ratingComment)) diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs new file mode 100644 index 000000000..b384143fd --- /dev/null +++ b/test/Handler/Utils/ZipSpec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Utils.ZipSpec where + +import TestImport + +import Handler.Utils.Zip + +import System.FilePath + +import Data.Conduit +import qualified Data.Conduit.List as Conduit + +import Data.List (dropWhileEnd) +import Data.Time + +instance Arbitrary File where + arbitrary = do + fileTitle <- joinPath <$> arbitrary + date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2) + fileModified <- addUTCTime <$> arbitrary <*> pure (UTCTime date 0) + fileContent <- arbitrary + return File{..} + +spec :: Spec +spec = describe "Zip file handling" $ do + it "has compatible encoding/decoding to/from zip files" . property $ + \zipFiles -> do + zipFiles' <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= void consumeZip =$= Conduit.consume + forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do + let acceptableFilenameChanges + = makeValid . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid + acceptableTimeDifference t1 t2 = abs (diffUTCTime t1 t2) <= 2 + (shouldBe `on` acceptableFilenameChanges) (fileTitle file') (fileTitle file) + when (inZipRange $ fileModified file) $ + (fileModified file', fileModified file) `shouldSatisfy` uncurry acceptableTimeDifference + (fileContent file') `shouldBe` (fileContent file) + +inZipRange :: UTCTime -> Bool +inZipRange time + | time > UTCTime (fromGregorian 1980 1 1) 0 + , time < UTCTime (fromGregorian 2107 1 1) 0 + = True + | otherwise + = False diff --git a/test/TestImport.hs b/test/TestImport.hs index 031453f19..29f09bdc6 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -22,6 +22,8 @@ import Yesod.Test as X import Yesod.Core.Unsafe (fakeHandlerGetLogger) import Test.QuickCheck as X import Test.QuickCheck.Gen as X +import Data.Default as X +import Test.QuickCheck.Instances as X runDB :: SqlPersistM a -> YesodExample UniWorX a runDB query = do @@ -84,3 +86,5 @@ authenticateAs (Entity _ User{..}) = do -- checking is switched off in wipeDB for those database backends which need it. createUser :: Text -> Text -> YesodExample UniWorX (Entity User) createUser userPlugin userIdent = runDB $ insertEntity User{..} + where + userMatrikelnummer = "DummyMatrikelnummer"