Course Edit compiles, but deletion/edit does not work yet. I think I need to separate Post/Get Handlers again.

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 
+    type            SheetType
-    maxPoints       Double Maybe
-    requiredPoints  Double Maybe
-    exerciseId      FileId Maybe
-    hintId          FileId Maybe
-    solutionId      FileId Maybe
-    markingId       FileId Maybe
     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
+    title           FilePath
-    content         ByteString
+    content         ByteString Maybe -- Nothing iff this is a directory
-    created         UTCTime
+    modified        UTCTime
-    changed         UTCTime
+    deriving Show Eq
-    createdBy       UserId
-    changedBy       UserId    
 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

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:

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 $ putStrLn "================" -- DEBUG
-    liftIO $ print (result,action)
+    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 $ putStrLn "++++++++++" -- DEBUG
-    liftIO $ print cid
+    liftIO $ print cid             -- DEBUG
     return $ case result of  
       FormSuccess courseResult 
         | errorMsgs <- validateCourse courseResult

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|
                   <a href=@{CourseShowTermR tn}> 
                     #{show numCourses} Kurse

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

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

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

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 
+type Points = Centi
-  deriving (Show, Read, Eq, Ord, Enum, Bounded) 
+
-derivePersistField "SheetType"
+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)

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

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))

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

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"