adding tagging feature to UI version 3

src-ui.v3/src/API.hs

@@ -78,6 +78,12 @@ data ClientFuns t m = ClientFuns
      , getV2PackageReports       :: Client t m (Capture "" PkgN :> Get '[JSON] (Set PkgIdxTs)) ()
      , getV2PackageReportSummary :: Client t m (Capture "" PkgN :> Capture "" PkgIdxTs :> Get '[JSON] PkgIdxTsReport) ()
      , getV2PackageReportDetail  :: Client t m (Capture "" PkgN :> Capture "" PkgIdxTs :> Capture "" Ver :> Capture "" CompilerID :> Get '[JSON] CellReportDetail) ()
+     , getV2PackageTags          :: Client t m (Capture "" PkgN :> Get '[JSON] (Vector TagN)) ()
+     , getV2TagsWithPackage      :: Client t m (QueryParam "pkgnames" Bool :> Get '[JSON] (Map TagN (Vector PkgN))) ()
+     , getV2TagsWithoutPackage   :: Client t m (QueryParam "pkgnames" Bool :> Get '[JSON] (Vector TagN)) ()
+     -- , getV2TagPackages          :: Client t m (Capture "" TagN :> Get '[JSON] (Vector PkgN)) ()
+     , putV2PackageTags          :: Client t m (Capture "" TagN :> Capture "" PkgN :> PutNoContent '[JSON] NoContent) ()
+     , deleteV2PackageTags       :: Client t m (Capture "" TagN :> Capture "" PkgN :> DeleteNoContent '[JSON] NoContent) ()
 
      , getV2UnitInfo             :: Client t m (Capture "" UUID :> Get '[JSON] UnitIdInfo) ()
 
@@ -87,6 +93,9 @@ data ClientFuns t m = ClientFuns
      , getV2Info                 :: Client t m (Get '[JSON] ControllerInfo) ()
      }
 
+tweakRequest = ClientOptions $ \r -> do
+  return $ r & withCredentials .~ True
+
 mkClientFuns :: forall t m . (HasClient t m API (), Reflex t) => BaseUrl -> ClientFuns t m
 mkClientFuns burl = ClientFuns {..}
   where
@@ -101,11 +110,17 @@ mkClientFuns burl = ClientFuns {..}
      :<|> getV2PackageReports
      :<|> getV2PackageReportSummary
      :<|> getV2PackageReportDetail
+     :<|> getV2PackageTags
+     :<|> getV2TagsWithPackage
+     :<|> getV2TagsWithoutPackage
+     -- :<|> getV2TagPackages
+     :<|> putV2PackageTags
+     :<|> deleteV2PackageTags
      :<|> getV2UnitInfo
      :<|> getV2Workers
      :<|> getV2WorkersPkg
      :<|> getV2User
-     ) = (client (Proxy :: Proxy API) Proxy (Proxy :: Proxy ()) (constDyn burl)) :: Client t m API ()
+     ) = (clientWithOpts (Proxy :: Proxy API) Proxy (Proxy :: Proxy ()) (constDyn burl) tweakRequest) :: Client t m API ()
 
 -- subset taken from "Controller.Api"
 type API =       "v2" :> "info"      :> Get '[JSON] ControllerInfo -- static meta-information
@@ -119,7 +134,12 @@ type API =       "v2" :> "info"      :> Get '[JSON] ControllerInfo -- static met
             :<|> "v2" :> "packages"  :> Capture "pkgname" PkgN :> "reports" :> Get '[JSON] (Set PkgIdxTs)
             :<|> "v2" :> "packages"  :> Capture "pkgname" PkgN :> "reports" :> Capture "idxstate" PkgIdxTs :> Get '[JSON] PkgIdxTsReport
             :<|> "v2" :> "packages"  :> Capture "pkgname" PkgN :> "reports" :> Capture "idxstate" PkgIdxTs :> Capture "pkgver" Ver :> Capture "hcver" CompilerID :> Get '[JSON] CellReportDetail
-
+            :<|> "v2" :> "packages"  :> Capture "pkgname" PkgN     :> "tags" :> Get '[JSON] (Vector TagN)
+            :<|> "v2" :> "tags"      :> QueryParam "pkgnames" Bool :> Get '[JSON] (Map TagN (Vector PkgN))
+            :<|> "v2" :> "tags"      :> QueryParam "pkgnames" Bool :> Get '[JSON] (Vector TagN)
+            -- :<|> "v2" :> "tags"      :> Capture "tagname" TagN :> Get '[JSON] (Vector PkgN)
+            :<|> "v2" :> "tags"      :> Capture "tagname" TagN :> Capture "pkgname" PkgN :> Put '[JSON] NoContent
+            :<|> "v2" :> "tags"      :> Capture "tagname" TagN :> Capture "pkgname" PkgN :> Delete '[JSON] NoContent
             :<|> "v2" :> "units" :> Capture "unitid" UUID :> Get '[JSON] UnitIdInfo
 
             :<|> "v2" :> "workers"   :> Get '[JSON] (Vector WorkerRow)

src-ui.v3/src/Main.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 
 {-# OPTIONS_GHC -Wall -Wno-unused-imports #-}
 
@@ -20,8 +21,11 @@ module Main (main) where
 import           Data.Aeson                (FromJSON)
 import qualified Data.Aeson                as J
 import qualified Data.Aeson.Types          as J
+import           Data.Bool                 (not)
 import qualified Data.Char                 as C
+import qualified Data.List                 as List
 import qualified Data.Map.Strict           as Map
+import           Data.Monoid               (Endo (Endo), appEndo)
 import           Data.Proxy
 import qualified Data.Set                  as Set
 import qualified Data.Text                 as T
@@ -36,13 +40,16 @@ import qualified Data.Vector               as V
 import qualified Data.Version              as Ver
 import           GHC.Generics              (Rep)
 import           Network.URI
-import           Reflex.Dom
+--import           Reflex.Dom
+import           Reflex.Dom.Core
 import           Reflex.Dom.Contrib.Router (route)
 import           Reflex.Dom.Location
 -- import           Reflex.Dom.Routing.Nested
-import           Control.Lens
+import           Control.Lens hiding (children, element)
+import           Control.Monad.Fix
 import           Reflex.Dom.Widget.Basic
 import           Reflex.Time
+import           Reflex.Class
 import           Servant.API
 import           Servant.Reflex
 
@@ -264,7 +271,13 @@ bodyElement4 = do
 
       RoutePackages -> pure $ do
           el "h1" $ text "Packages"
-          packagesPageWidget dynPackages0
+          evPB <- getPostBuild
+          evTags <- fmapMaybe reqSuccess <$> getV2TagsWithoutPackage (constDyn $ QParamSome False) evPB
+          dynTags <- holdDyn mempty evTags
+          evTagPkgs <- fmapMaybe reqSuccess <$> getV2TagsWithPackage (constDyn $ QParamSome True) evPB
+          dynTagPkgs <- holdDyn Map.empty evTagPkgs
+          let dynPkgTags = pkgTagList <$> dynTagPkgs
+          packagesPageWidget dynPackages0 dynTags dynPkgTags
 
       RoutePackage pn -> pure $ do
           el "h2" $ text (unPkgN pn)
@@ -275,7 +288,7 @@ bodyElement4 = do
 
           -- single-shot requests
 
-          evReports <- fmapMaybe reqSuccess <$> getV2PackageReports  (constDyn $ Right pn) evPB
+          evReports <- fmapMaybe reqSuccess <$> getV2PackageReports (constDyn $ Right pn) evPB
           dynReports <- holdDyn mempty evReports
 
           evInfo <- fmapMaybe reqSuccess <$> getV2Info evPB
@@ -284,6 +297,9 @@ bodyElement4 = do
           evHist  <- fmapMaybe reqSuccess <$> getV2PackageHistory (constDyn $ Right pn) (leftmost [updated dynIdxStLast $> (), evPB])
           dynHist <- holdDyn mempty evHist
 
+          evPkgTags <- fmapMaybe reqSuccess <$> getV2PackageTags (constDyn $ Right pn) evPB
+          dynPkgTags <- holdDyn mempty evPkgTags
+
           -- other requests
 
           evQRows <- (fmapMaybe reqSuccess) <$>
@@ -306,26 +322,52 @@ bodyElement4 = do
           let xs = Map.fromList . fmap (\x -> (x, pkgIdxTsToText x)) . Set.toList <$> dynReports
               x0 = (\s -> if Set.null s then PkgIdxTs 0 else Set.findMax s) <$> dynReports
 
-          let cfg = DropdownConfig (updated x0) (constDyn mempty)
+          let ddCfg = DropdownConfig (updated x0) (constDyn mempty)
+
+          let inputAttr = ("class" =: "tag-name") <> ("placeholder" =: "insert tag")
+              iCfg = TextInputConfig "tag-name" "" never (constDyn inputAttr)
 
           ddReports <- el "p" $ do
             evQButton <- button "Queue a build"
             text " for the index-state "
-            tmp <- dropdown (PkgIdxTs 0) xs cfg
+            tmp <- dropdown (PkgIdxTs 0) xs ddCfg
             text " shown below"
 
             _ <- putV2Queue (constDyn $ Right pn) (Right <$> _dropdown_value tmp) (constDyn $ Right (QEntryUpd (-1))) evQButton
 
             pure tmp
-
+
+          tagsMapDyn <- elClass "p" "tagging" $ mdo
+            let evMapTags = Map.fromList . (fmap (\t -> (t,t))) . (fmap tagNToText) . V.toList <$> evPkgTags
+            result <- foldDyn appEndo Map.empty $ fold
+              [ Endo . const <$> evMapTags
+              , (\nTag -> Endo $ Map.insert nTag nTag) <$> addTag0
+              , (foldMap (Endo . Map.delete) . Map.keys) <$> deleteTag0
+              ]
+            deleteTag0 :: Event t (Map.Map T.Text T.Text) <- listViewWithKey result $ \tId _ -> do
+              el "li" $ do
+                el "span" $ text tId
+                delEv <- rmTagButton_ tId pn
+                pure $ tagNToText <$> delEv
+
+            addTag0 <- elClass "form" "form" $ do
+              el "p" $ text "Tag : "
+              tagName <- textInput iCfg
+              tagButton <- button_ "Add Tag"
+              let tVal = _textInput_value tagName
+                  evAdd = (tagPromptlyDyn tVal tagButton)
+              addTagN <- holdDyn "" evAdd
+              addResult <- fmapMaybe reqSuccess <$> putV2PackageTags ((Right . TagN) <$> addTagN) (constDyn $ Right pn) (() <$ evAdd)
+              pure $ tagPromptlyDyn tVal addResult
+            pure ()
+
           let evReports' = updated (_dropdown_value ddReports)
               dynIdxSt   = ddReports ^. dropdown_value
 
           evRepSum <- fmapMaybe reqSuccess <$> getV2PackageReportSummary (constDyn $ Right pn) (Right <$> dynIdxSt) (leftmost [evReports' $> (), ticker4 $> ()])
 
           dynRepSum <- holdUniqDyn =<< holdDyn (PkgIdxTsReport pn (PkgIdxTs 0) [] mempty) evRepSum
 
-
           el "hr" blank
 
           evCellClick <- reportTableWidget dynRepSum dynQRows dynWorkers dynHist dynInfo
@@ -363,6 +405,8 @@ bodyElement4 = do
 
     unPkgN (PkgN x) = x
 
+    unTagN (TagN x) = x
+
     pkgLink pn' = elDynAttr "a" (pkgHref <$> pn') $ dynText (unPkgN <$> pn')
 
     pkgHref (PkgN pn')
@@ -374,6 +418,15 @@ bodyElement4 = do
     mergeCellId _ Nothing _           = Nothing
     mergeCellId pn (Just (pv,hcv)) is = Just (pn,pv,hcv,is)
 
+    rmTagButton_ :: T.Text -> PkgN -> m (Event t TagN)
+    rmTagButton_ tId pn = do
+      rmTag <- do
+        (ev1,_) <- elAttr' "a" ("class" =: "remove") $ do
+                     text " X "
+        pure $ domEvent Click ev1
+      delResult <- fmapMaybe reqSuccess <$> deleteV2PackageTags (constDyn $ Right (TagN tId)) (constDyn $ Right pn) rmTag
+      pure $ (TagN tId) <$ delResult
+
 
 data FragRoute = RouteHome
                | RouteQueue
@@ -405,10 +458,29 @@ decodeFrag frag = case frag of
 
 
 -- | Renders alpha-tabbed package index
-packagesPageWidget :: (MonadHold t m, PostBuild t m, DomBuilder t m) => Dynamic t (Vector PkgN) -> m ()
-packagesPageWidget dynPackages = do
+packagesPageWidget :: forall t m. (MonadFix m, MonadHold t m, PostBuild t m, DomBuilder t m) 
+                   => Dynamic t (Vector PkgN) 
+                   -> Dynamic t (Vector TagN) 
+                   -> Dynamic t (Map.Map PkgN [TagN])
+                   -> m ()
+packagesPageWidget dynPackages dynTags dynPkgTags = do
     display (V.length <$> dynPackages)
 
+    dynTags' <- dyn $ do           
+      v <- dynTags
+      let v' = V.toList v 
+      pure $ do 
+        dynTagSet <- elClass "ol" "tag-filter clearfix" $ do
+            result <- forM v' $ \(tn) -> do
+                (ev1, _) <- el "li" $
+                             elAttr' "a" ("class" =: "tag-item") $ do
+                                text (tagNToText tn)
+                pure $ tn <$ (domEvent Click ev1)
+            pure $ leftmost result
+        foldDyn toggleTagSet Set.empty dynTagSet
+    dynSet' <- holdDyn (constDyn Set.empty) dynTags'
+    let dynSet = join dynSet'
+
     dynPF <- el "div" $ do
       text "[ "
       eButton0 <- button "0-9"
@@ -418,24 +490,32 @@ packagesPageWidget dynPackages = do
         button (T.singleton c)
 
       text " ]"
-
       holdDyn 'A' (leftmost [ e $> c | (e,c) <- zip (eButton0:eButtons) ('*':['A'..'Z']) ])
 
     -- this is faster than simpleList
     _ <- dyn $ do v <- dynPackages
                   pf <- dynPF
-                  let v' = V.toList . evalPkgFilter pf $ v
+                  st <- dynSet
+                  dpt <- dynPkgTags
+                  let v' = V.toList . (evalTagFilter st dpt) . evalPkgFilter pf $ v
 
                   pure $ do
-                    el "ol" $ forM_ v' $ \(PkgN pn) -> do
-                      el "li" $ elAttr "a" ("href" =: ("#/package/" <> pn)) $ text pn
+
+                    el "ol" $ forM_ v' $ \(pn) -> do
+                      el "li" $ elAttr "a" ("href" =: ("#/package/" <> (pkgNToText pn))) $ do
+                        text ((pkgNToText pn) <> " : ")
+                        case Map.lookup pn dpt of
+                          Just tags -> forM tags $ \(tag0) -> elAttr "a" (("class" =: "tag-item") <> ("data-tag-name" =: (tagNToText tag0))) $ text (tagNToText tag0)
+                          Nothing   -> pure ([])
 
     pure ()
   where
     evalPkgFilter '*' = V.takeWhile (\(PkgN t) -> T.head t < 'A')
     evalPkgFilter c   = V.takeWhile f . V.dropWhile (not . f)
       where
         f (PkgN x) = let c' = T.head x in c' == c || c' == (C.toLower c)
+    evalTagFilter st dpt pkg =
+      V.filter (tagContained st dpt) pkg
 
 
 reportTableWidget :: forall t m . (MonadWidget t m, MonadHold t m, PostBuild t m, DomBuilder t m)
@@ -617,7 +697,36 @@ applyLR (L:xs)  (l:ls)    rs  = l : applyLR xs ls rs
 applyLR (R:xs)     ls  (r:rs) = r : applyLR xs ls rs
 applyLR _ _ _                 = error "applyLR"
 
+toggleTagSet :: TagN -> Set.Set TagN -> Set.Set TagN
+toggleTagSet tn st = if Set.member tn st then Set.delete tn st else Set.insert tn st
+
+tagContained :: Set.Set TagN -> Map.Map PkgN [TagN] -> PkgN -> Bool
+tagContained st pkgTags pkg
+  | Set.null st = True
+  | otherwise    =
+    let 
+      tags = 
+        case Map.lookup pkg pkgTags of
+          Just a  -> a 
+          Nothing -> []
+        in not $ Set.null (Set.fromList tags `Set.intersection` st)
 
 
+pkgTagList :: (Map.Map TagN (Vector PkgN))
+           -> (Map.Map PkgN [TagN])
+pkgTagList m = Map.fromListWith (List.++) $ do
+  (k, vs) <- Map.toList m
+  v <- (V.toList vs)
+  pure $ (v, [k])
+
 joinE :: forall t m a . (Reflex t, MonadHold t m) => Event t (Event t a) -> m (Event t a)
 joinE = fmap switch . hold never
+
+button_ :: forall t m a. (DomBuilder t m, PostBuild t m) => T.Text -> m (Event t ())
+button_ t = do
+  let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
+        & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
+  (e, _) <- element "button" cfg $ text t
+  pure $ domEvent Click e
+
+

src-ui.v3/src/PkgId.hs

@@ -6,6 +6,7 @@
 --
 module PkgId
     ( PkgN(..)
+    , TagN(..)
     , pkgNFromText
 
     , Ver
@@ -141,3 +142,6 @@ verToText (Ver x) = T.pack . Ver.showVersion . Ver.makeVersion $ x
 --     go (_ : xs) = go xs
 --     go _        = fail "could not parse Version"
 
+----------------------------------------------------------------------------
+newtype TagN = TagN { tagNToText :: Text }
+  deriving (Eq,Ord,FromJSON,ToJSON,ToJSONKey,FromJSONKey,FromHttpApiData,ToHttpApiData)