Minor code cleaning cd /home/jost/programming/Haskell/Yesod/uniworx/templates

messages/uniworx/de.msg

@@ -75,15 +75,15 @@ CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
 Sheet: Blatt
 SheetList          tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter
 SheetNewHeading    tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen
-SheetNewOk         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt.
+SheetNewOk         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wurde als neues Übungsblatt im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt.
 SheetTitle         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
 SheetTitleNew      tid@TermId ssh@SchoolId courseShortHand@CourseShorthand                    : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt
 SheetEditHead      tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren
 SheetEditOk        tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert.
 SheetNameDup       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{courseShortHand}.
-SheetDelHead       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen?
+SheetDelHead       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen?
 SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
-SheetDelOk         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
+SheetDelOk         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: #{sheetName} gelöscht.
 
 SheetExercise: Aufgabenstellung
 SheetHint: Hinweis
@@ -132,7 +132,7 @@ SubmissionGroupName: Gruppenname
 
 CorrectionsTitle: Zugewiesene Korrekturen
 CourseCorrectionsTitle: Korrekturen für diesen Kurs
-CorrectorsHead sheetName@SheetName: Korrektoren für Blatt #{sheetName}
+CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
 
 Unauthorized: Sie haben hierfür keine explizite Berechtigung.
 UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})

routes

@@ -51,6 +51,7 @@
 /school                    SchoolListR       GET
 /school/#SchoolId          SchoolShowR       GET
 
+
 -- For Pattern Synonyms see Foundation
 /course/                    CourseListR       GET             !free
 !/course/new                CourseNewR        GET POST        !lecturer
@@ -76,6 +77,11 @@
     /correctors                 SCorrR        GET POST
     !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
 
+-- /user/#CryptoUUIDUser
+-- /users
+-- /correctors
+
+
 /corrections  CorrectionsR GET POST !corrector !lecturer
 /corrections/upload CorrectionsUploadR GET POST !corrector !lecturer
 

src/Handler/Course.hs

@@ -343,7 +343,7 @@ courseDeleteHandler = undefined
 
 courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
 courseEditHandler isGet course = do
-    $logDebug "€€€€€€ courseEditHandler started"
+    -- $logDebug "€€€€€€ courseEditHandler started"
     aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
     ((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm
     case result of

src/Handler/Profile.hs

@@ -452,7 +452,7 @@ mkCorrectionsTable =
             sheetCell    <$> view _1 <*> view _2
         , sortable (Just "cstate") (i18nCell MsgCorState) $
             correctorStateCell <$> view (_dbrOutput . _3 . _entityVal)
-        , sortable (Just "cload")  (i18nCell MsgCorProportion) $
+        , sortable (toNothing "cload")  (i18nCell MsgCorProportion) $
             correctorLoadCell  <$> view (_dbrOutput . _3 . _entityVal)
         ]
 
@@ -463,7 +463,6 @@ mkCorrectionsTable =
         , ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse  E.^. CourseShorthand)
         , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _) -> sheet E.^. SheetName      )
         , ( "cstate", SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` cs)    -> cs    E.^. SheetCorrectorState )
-        , ( "cload" , SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` cs)    -> cs    E.^. SheetCorrectorLoad  )
         ]
       dbtFilter = Map.fromList
         [ ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )

src/Handler/Utils/DateTime.hs

@@ -11,6 +11,7 @@ module Handler.Utils.DateTime
   , formatTime, formatTime', formatTimeW
   , getTimeLocale, getDateTimeFormat
   , validDateTimeFormats, dateTimeFormatOptions
+  , addOneWeek
   ) where
 
 import Import
@@ -19,6 +20,7 @@ import Data.Time.Zones hiding (localTimeToUTCFull)
 import qualified Data.Time.Zones as TZ
 
 import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
+import Data.Time.Clock (addUTCTime,nominalDay)
 import qualified Data.Time.Format as Time
 
 import Data.Set (Set)
@@ -130,3 +132,10 @@ dateTimeFormatOptions sel = do
       return $ (dateTime, fmt)
   
   optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel 
+
+
+addOneWeek :: UTCTime -> UTCTime
+addOneWeek = addUTCTime (7 * nominalDay)
+
+-- addOneTerm? -> Move Handler.Utils.DateTime
+

src/Model/Migration.hs

@@ -23,6 +23,7 @@ import qualified Data.Set as Set
 import Database.Persist.Sql
 import Database.Persist.Postgresql
 
+import Text.Read (readMaybe)
 import Data.CaseInsensitive (CI)
 
 -- Database versions must follow https://pvp.haskell.org:
@@ -151,6 +152,16 @@ customMigrations = Map.fromListWith (>>)
             ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
           |]
     )
+  , ( AppliedMigrationKey [migrationVersion|2.0.0|] [version|3.0.0|]
+    , whenM (tableExists "sheet_corrector") $ do
+        correctorLoads <- [sqlQQ| SELECT "id", "load" FROM "sheet_corrector"; |]
+        forM_ correctorLoads $ \(uid, Single str) -> case readMaybe str of
+          Just load -> update uid [SheetCorrectorLoad =. load]
+          _other -> error $ "Could not parse Load: " <> show str
+        [executeQQ|
+          ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE json USING "load"::json;
+        |]
+    )
   ]
 
 

src/Model/Types.hs

@@ -203,7 +203,12 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
            , byProportion :: Rational  -- ^ workload proportion of all submission not assigned to tutorial leaders
            }
   deriving (Show, Read, Eq, Ord)
-derivePersistField "Load"
+
+deriveJSON defaultOptions ''Load
+derivePersistFieldJSON ''Load
+
+
+
 
 instance Semigroup Load where
   (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')

src/Utils.hs

@@ -104,9 +104,6 @@ tickmarkT = tickmark
 text2Html :: Text -> Html
 text2Html = toHtml -- prevents ambiguous types
 
-liftCI :: (Text -> Text) -> (CI Text) -> (CI Text)
-liftCI f ci = CI.mk $ f $ CI.original ci
-
 toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
   a -> WidgetT site m ()
 toWgt = toWidget . toHtml
@@ -133,6 +130,7 @@ withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >>
 
 
 -- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
+{-# DEPRECATED display "Create RenderMessage Instances instead!" #-}
 class DisplayAble a where
   display :: a -> Text
   -- Default definitions for types belonging to Show (allows empty instance declarations)
@@ -185,7 +183,7 @@ textPercent x = lz <> (pack $ show rx) <> "%"
    lz = if rx < 10.0 then "0" else ""
 
 stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
-stepTextCounterCI = liftCI stepTextCounter
+stepTextCounterCI = CI.map stepTextCounter
 
 stepTextCounter :: Text -> Text -- find and increment rightmost-number, preserving leading zeroes
 stepTextCounter text

src/Utils/DateTime.hs

@@ -10,7 +10,6 @@ module Utils.DateTime
   ( timeLocaleMap
   , TimeLocale(..)
   , currentYear
-  , addOneWeek
   , module Data.Time.Zones
   , module Data.Time.Zones.TH
   ) where
@@ -19,7 +18,6 @@ import ClassyPrelude.Yesod hiding (lift)
 import System.Locale.Read
 
 import Data.Time (TimeZone(..), TimeLocale(..))
-import Data.Time.Clock (addUTCTime,nominalDay)
 import Data.Time.Zones (TZ)
 import Data.Time.Zones.TH (includeSystemTZ)
 
@@ -31,10 +29,6 @@ deriving instance Lift TimeZone
 deriving instance Lift TimeLocale
 
 
-addOneWeek :: UTCTime -> UTCTime
-addOneWeek = addUTCTime (7 * nominalDay) --better use nominalWeek
-
-
 -- $(timeLocaleMap _) :: [Lang] -> TimeLocale
 timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
               -> ExpQ

templates/default-layout.hamlet

@@ -15,8 +15,9 @@
     <div .main__content-body>
 
       <h1>
-        $maybe back <- lastMaybe parents
+        <!-- $maybe back <- lastMaybe parents
-          <a .breadcrumbs__link href="@{fst back}">#{snd back}
+            <a .breadcrumbs__link href="@{fst back}">#{snd back}
+          -->
         $maybe headline <- contentHeadline
           ^{headline}
         $nothing