Uniwory und PageAction ExerciseSheet

routes

@@ -12,6 +12,7 @@
 /term/edit                  TermEditR         GET POST        !adminAny
 /term/#TermId/edit          TermEditExistR    GET             !adminAny
 
+-- For Pattern Synonyms see Foundation
 /course/                    CourseListR       GET
 !/course/new                CourseNewR        GET POST        !lecturerAny
 !/course/#TermId            CourseListTermR   GET

src/Foundation.hs

@@ -350,7 +350,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
 
 
-  breadcrumb HomeR = return ("UniworkY", Nothing)
+  breadcrumb HomeR = return ("Uniworky", Nothing)
   breadcrumb (AuthR _) = return ("Login", Just HomeR)
   breadcrumb ProfileR = return ("Profile", Just HomeR)
   breadcrumb  _ = return ("home", Nothing)

src/Handler/Home.hs

@@ -43,7 +43,7 @@ getHomeR :: Handler Html
 getHomeR = do
   (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
   defaultLayout $ do
-    setTitle "Willkommen zum UniworkY Test!"
+    setTitle "Willkommen zum Uniworky Test!"
     $(widgetFile "home")
 
 

src/Handler/Sheet.hs

@@ -196,7 +196,15 @@ getSheetShowR tid csh shn = do
       return $ (file E.^. FileTitle, sheetFile E.^. SheetFileType)
   let fileLinks = map (\(E.Value fName, E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName)) fileNameTypes
 
-  defaultLayout $ do
+  let pageActions =
+        [ PageActionPrime $ MenuItem
+          { menuItemLabel = "Abgabe"
+          , menuItemIcon  = Nothing
+          , menuItemRoute = CSheetR tid csh SheetNewR
+          , menuItemAccessCallback' = return True
+          }
+        ]
+  defaultLinkLayout pageActions $ do
     setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
     $(widgetFile "sheetShow")
     [whamlet| Under Construction !!! |] -- TODO

src/Handler/Submission.hs

@@ -42,6 +42,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Bifunctor
 
 import System.FilePath
 
@@ -125,7 +126,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
             E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
             E.limit 1
             return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime)
-        let lastEdits = map (\(a,b)-> (E.unValue a, E.unValue b)) lastEditValues
+        let lastEdits = map (bimap E.unValue E.unValue) lastEditValues
         return (sheet,buddies,oldfiles,lastEdits)
   let unpackZips = True -- undefined -- TODO
   ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips sheetGrouping $ map E.unValue buddies

src/Handler/Utils/Form.hs

@@ -15,9 +15,11 @@ module Handler.Utils.Form where
 
 import Handler.Utils.Form.Types
 
+
+import Handler.Utils.DateTime
+
 import Import
 import qualified Data.Char as Char
-import Handler.Utils.DateTime
 import Data.String (IsString(..))
 
 import qualified Data.Foldable as Foldable
@@ -328,6 +330,25 @@ sheetGroupAFormReq d _other = -- TODO
   -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
   Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)
 
+{-
+dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
+dayTimeField fs mutc = do
+    let (mbDay,mbTime) = case mutcs of
+          Nothing    -> return (Nothing,Nothing)
+          (Just utc) ->
+
+    (dayResult, dayView) <- mreq dayField fs
+
+    (result, view) <- (,) <$> dayField <*> timeField
+  where
+    (mbDay,mbTime)
+      | (Just utc) <- mutc =
+          let lt = utcToLocalTime ??? utcs
+          in  (Just $ localDay lt, Just $ localTimeOfDay lt)
+      | otherwise = (Nothing,Nothing)
+-}
+
+
 utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime
 -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
 -- TODO: Verify whether this is UTC or local time from Browser

src/Utils.hs

@@ -53,10 +53,6 @@ whenIsJust Nothing  _ = return ()
 -- Tuples --
 ------------
 
-both :: (a -> b) -> (a,a) -> (b,b)
-both f (x,y) = (f x, f y)
-
-
 ----------
 -- Maps --
 ----------

templates/home.hamlet

@@ -1,5 +1,5 @@
 <div .container>
-  <h1>UniworkY - Demo
+  <h1>Uniworky - Demo
   <h3>
     Testumgebung für die Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
   <p>