From cf764665177358019d786ad70c8cbcb12aeff7a9 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 5 Jul 2018 11:55:26 +0200
Subject: [PATCH] Further refine links in dbTable

---
 src/Handler/Home.hs                   |  6 +++---
 src/Handler/Utils/Table/Pagination.hs | 21 +++++++++++++++++----
 2 files changed, 20 insertions(+), 7 deletions(-)

diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index e820dac45..7cb91dc30 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -153,10 +153,10 @@ homeUser uid = do
             cell [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
         , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } ->
             textCell $ display deadline
-        , sortable (Just "done")   (textCell MsgDone)   $ \dbrow@(DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
+        , sortable (Just "done")   (textCell MsgDone)   $ \(DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
             case mbsid of
-              Nothing    -> textCell (" " :: Text)
-              (Just sid) -> anchorCell (CSheetR tid csh shn SubmissionOwnR)
+              Nothing    -> mempty
+              (Just sid) -> anchorCellM (CSubmissionR tid csh shn <$> encrypt sid <*> pure SubShowR)
                                         tickmark
         ]
   let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 62a42ffbd..aeedaea1f 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -29,7 +29,7 @@ module Handler.Utils.Table.Pagination
   , ToSortable(..), Sortable(..), sortable
   , dbTable
   , widgetColonnade, formColonnade
-  , textCell, stringCell, i18nCell, anchorCell, anchorCell'
+  , textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM
   , formCell, DBFormResult, getDBFormResult
   , dbRow, dbSelect
   ) where
@@ -193,7 +193,7 @@ restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> ov
   where
     restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
 
-class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where
+class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where
   type DBResult m x :: *
   -- type DBResult' m x :: *
 
@@ -225,6 +225,10 @@ instance IsDBTable (WidgetT UniWorX IO) () where
   dbWidget Proxy Proxy = return
   runDBTable = return . join . fmap (view _2)
 
+instance Monoid (DBCell (WidgetT UniWorX IO) ()) where
+  mempty = WidgetCell mempty mempty
+  (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend c c')
+
 instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
   -- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
   type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a
@@ -247,6 +251,10 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
   -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
   runDBTable = return . withFragment
 
+instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
+  mempty = FormCell mempty (return mempty)
+  (FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c')
+  
 instance IsDBTable m a => IsString (DBCell m a) where
   fromString = cell . fromString
       
@@ -370,15 +378,20 @@ stringCell = textCell
 i18nCell = textCell
 textCell msg = cell [whamlet|_{msg}|]
 
+anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
+anchorCell = anchorCellM . return
+
 anchorCell' :: IsDBTable m a
            => (r -> Route UniWorX)
            -> (r -> Widget)
            -> (r -> DBCell m a)
 anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
 
-anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
-anchorCell route widget = cell $ do
+anchorCellM :: IsDBTable m a => (WidgetT UniWorX IO (Route UniWorX)) -> Widget -> DBCell m a
+anchorCellM routeM widget = cell $ do
+  route <- routeM
   authResult <- liftHandlerT $ isAuthorized route False
+
   if
     | Authorized <- authResult -> $(widgetFile "table/cell/link")
     | otherwise                -> widget