Skip to content

Commit 7041da2

Browse files
hvrhvr
committed
Merge PR #58 (UI tagging feature)
addresses part of #57
2 parents 6d6ab8e + d4ebff6 commit 7041da2

File tree

3 files changed

+149
-16
lines changed

3 files changed

+149
-16
lines changed

‎src-ui.v3/src/API.hs‎

Lines changed: 22 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -78,6 +78,12 @@ data ClientFuns t m = ClientFuns
7878
, getV2PackageReports :: Client t m (Capture "" PkgN :> Get '[JSON] (Set PkgIdxTs)) ()
7979
, getV2PackageReportSummary :: Client t m (Capture "" PkgN :> Capture "" PkgIdxTs :> Get '[JSON] PkgIdxTsReport) ()
8080
, getV2PackageReportDetail :: Client t m (Capture "" PkgN :> Capture "" PkgIdxTs :> Capture "" Ver :> Capture "" CompilerID :> Get '[JSON] CellReportDetail) ()
81+
, getV2PackageTags :: Client t m (Capture "" PkgN :> Get '[JSON] (Vector TagN)) ()
82+
, getV2TagsWithPackage :: Client t m (QueryParam "pkgnames" Bool :> Get '[JSON] (Map TagN (Vector PkgN))) ()
83+
, getV2TagsWithoutPackage :: Client t m (QueryParam "pkgnames" Bool :> Get '[JSON] (Vector TagN)) ()
84+
-- , getV2TagPackages :: Client t m (Capture "" TagN :> Get '[JSON] (Vector PkgN)) ()
85+
, putV2PackageTags :: Client t m (Capture "" TagN :> Capture "" PkgN :> PutNoContent '[JSON] NoContent) ()
86+
, deleteV2PackageTags :: Client t m (Capture "" TagN :> Capture "" PkgN :> DeleteNoContent '[JSON] NoContent) ()
8187

8288
, getV2UnitInfo :: Client t m (Capture "" UUID :> Get '[JSON] UnitIdInfo) ()
8389

@@ -87,6 +93,9 @@ data ClientFuns t m = ClientFuns
8793
, getV2Info :: Client t m (Get '[JSON] ControllerInfo) ()
8894
}
8995

96+
tweakRequest = ClientOptions $ \r -> do
97+
return $ r & withCredentials .~ True
98+
9099
mkClientFuns :: forall t m . (HasClient t m API (), Reflex t) => BaseUrl -> ClientFuns t m
91100
mkClientFuns burl = ClientFuns {..}
92101
where
@@ -101,11 +110,17 @@ mkClientFuns burl = ClientFuns {..}
101110
:<|> getV2PackageReports
102111
:<|> getV2PackageReportSummary
103112
:<|> getV2PackageReportDetail
113+
:<|> getV2PackageTags
114+
:<|> getV2TagsWithPackage
115+
:<|> getV2TagsWithoutPackage
116+
-- :<|> getV2TagPackages
117+
:<|> putV2PackageTags
118+
:<|> deleteV2PackageTags
104119
:<|> getV2UnitInfo
105120
:<|> getV2Workers
106121
:<|> getV2WorkersPkg
107122
:<|> getV2User
108-
) = (client (Proxy :: Proxy API) Proxy (Proxy :: Proxy ()) (constDyn burl)) :: Client t m API ()
123+
) = (clientWithOpts (Proxy :: Proxy API) Proxy (Proxy :: Proxy ()) (constDyn burl) tweakRequest) :: Client t m API ()
109124

110125
-- subset taken from "Controller.Api"
111126
type API = "v2" :> "info" :> Get '[JSON] ControllerInfo -- static meta-information
@@ -119,7 +134,12 @@ type API = "v2" :> "info" :> Get '[JSON] ControllerInfo -- static met
119134
:<|> "v2" :> "packages" :> Capture "pkgname" PkgN :> "reports" :> Get '[JSON] (Set PkgIdxTs)
120135
:<|> "v2" :> "packages" :> Capture "pkgname" PkgN :> "reports" :> Capture "idxstate" PkgIdxTs :> Get '[JSON] PkgIdxTsReport
121136
:<|> "v2" :> "packages" :> Capture "pkgname" PkgN :> "reports" :> Capture "idxstate" PkgIdxTs :> Capture "pkgver" Ver :> Capture "hcver" CompilerID :> Get '[JSON] CellReportDetail
122-
137+
:<|> "v2" :> "packages" :> Capture "pkgname" PkgN :> "tags" :> Get '[JSON] (Vector TagN)
138+
:<|> "v2" :> "tags" :> QueryParam "pkgnames" Bool :> Get '[JSON] (Map TagN (Vector PkgN))
139+
:<|> "v2" :> "tags" :> QueryParam "pkgnames" Bool :> Get '[JSON] (Vector TagN)
140+
-- :<|> "v2" :> "tags" :> Capture "tagname" TagN :> Get '[JSON] (Vector PkgN)
141+
:<|> "v2" :> "tags" :> Capture "tagname" TagN :> Capture "pkgname" PkgN :> Put '[JSON] NoContent
142+
:<|> "v2" :> "tags" :> Capture "tagname" TagN :> Capture "pkgname" PkgN :> Delete '[JSON] NoContent
123143
:<|> "v2" :> "units" :> Capture "unitid" UUID :> Get '[JSON] UnitIdInfo
124144

125145
:<|> "v2" :> "workers" :> Get '[JSON] (Vector WorkerRow)

‎src-ui.v3/src/Main.hs‎

Lines changed: 123 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88
{-# LANGUAGE ScopedTypeVariables #-}
99
{-# LANGUAGE TypeApplications #-}
1010
{-# LANGUAGE TypeOperators #-}
11+
{-# LANGUAGE AllowAmbiguousTypes #-}
1112

1213
{-# OPTIONS_GHC -Wall -Wno-unused-imports #-}
1314

@@ -20,8 +21,11 @@ module Main (main) where
2021
import Data.Aeson (FromJSON)
2122
import qualified Data.Aeson as J
2223
import qualified Data.Aeson.Types as J
24+
import Data.Bool (not)
2325
import qualified Data.Char as C
26+
import qualified Data.List as List
2427
import qualified Data.Map.Strict as Map
28+
import Data.Monoid (Endo (Endo), appEndo)
2529
import Data.Proxy
2630
import qualified Data.Set as Set
2731
import qualified Data.Text as T
@@ -36,13 +40,16 @@ import qualified Data.Vector as V
3640
import qualified Data.Version as Ver
3741
import GHC.Generics (Rep)
3842
import Network.URI
39-
import Reflex.Dom
43+
--import Reflex.Dom
44+
import Reflex.Dom.Core
4045
import Reflex.Dom.Contrib.Router (route)
4146
import Reflex.Dom.Location
4247
-- import Reflex.Dom.Routing.Nested
43-
import Control.Lens
48+
import Control.Lens hiding (children, element)
49+
import Control.Monad.Fix
4450
import Reflex.Dom.Widget.Basic
4551
import Reflex.Time
52+
import Reflex.Class
4653
import Servant.API
4754
import Servant.Reflex
4855

@@ -264,7 +271,13 @@ bodyElement4 = do
264271

265272
RoutePackages -> pure $ do
266273
el "h1" $ text "Packages"
267-
packagesPageWidget dynPackages0
274+
evPB <- getPostBuild
275+
evTags <- fmapMaybe reqSuccess <$> getV2TagsWithoutPackage (constDyn $ QParamSome False) evPB
276+
dynTags <- holdDyn mempty evTags
277+
evTagPkgs <- fmapMaybe reqSuccess <$> getV2TagsWithPackage (constDyn $ QParamSome True) evPB
278+
dynTagPkgs <- holdDyn Map.empty evTagPkgs
279+
let dynPkgTags = pkgTagList <$> dynTagPkgs
280+
packagesPageWidget dynPackages0 dynTags dynPkgTags
268281

269282
RoutePackage pn -> pure $ do
270283
el "h2" $ text (unPkgN pn)
@@ -275,7 +288,7 @@ bodyElement4 = do
275288

276289
-- single-shot requests
277290

278-
evReports <- fmapMaybe reqSuccess <$> getV2PackageReports (constDyn $ Right pn) evPB
291+
evReports <- fmapMaybe reqSuccess <$> getV2PackageReports (constDyn $ Right pn) evPB
279292
dynReports <- holdDyn mempty evReports
280293

281294
evInfo <- fmapMaybe reqSuccess <$> getV2Info evPB
@@ -284,6 +297,9 @@ bodyElement4 = do
284297
evHist <- fmapMaybe reqSuccess <$> getV2PackageHistory (constDyn $ Right pn) (leftmost [updated dynIdxStLast $> (), evPB])
285298
dynHist <- holdDyn mempty evHist
286299

300+
evPkgTags <- fmapMaybe reqSuccess <$> getV2PackageTags (constDyn $ Right pn) evPB
301+
dynPkgTags <- holdDyn mempty evPkgTags
302+
287303
-- other requests
288304

289305
evQRows <- (fmapMaybe reqSuccess) <$>
@@ -306,26 +322,52 @@ bodyElement4 = do
306322
let xs = Map.fromList . fmap (\x -> (x, pkgIdxTsToText x)) . Set.toList <$> dynReports
307323
x0 = (\s -> if Set.null s then PkgIdxTs 0 else Set.findMax s) <$> dynReports
308324

309-
let cfg = DropdownConfig (updated x0) (constDyn mempty)
325+
let ddCfg = DropdownConfig (updated x0) (constDyn mempty)
326+
327+
let inputAttr = ("class" =: "tag-name") <> ("placeholder" =: "insert tag")
328+
iCfg = TextInputConfig "tag-name" "" never (constDyn inputAttr)
310329

311330
ddReports <- el "p" $ do
312331
evQButton <- button "Queue a build"
313332
text " for the index-state "
314-
tmp <- dropdown (PkgIdxTs 0) xs cfg
333+
tmp <- dropdown (PkgIdxTs 0) xs ddCfg
315334
text " shown below"
316335

317336
_ <- putV2Queue (constDyn $ Right pn) (Right <$> _dropdown_value tmp) (constDyn $ Right (QEntryUpd (-1))) evQButton
318337

319338
pure tmp
320-
339+
340+
tagsMapDyn <- elClass "p" "tagging" $ mdo
341+
let evMapTags = Map.fromList . (fmap (\t -> (t,t))) . (fmap tagNToText) . V.toList <$> evPkgTags
342+
result <- foldDyn appEndo Map.empty $ fold
343+
[ Endo . const <$> evMapTags
344+
, (\nTag -> Endo $ Map.insert nTag nTag) <$> addTag0
345+
, (foldMap (Endo . Map.delete) . Map.keys) <$> deleteTag0
346+
]
347+
deleteTag0 :: Event t (Map.Map T.Text T.Text) <- listViewWithKey result $ \tId _ -> do
348+
el "li" $ do
349+
el "span" $ text tId
350+
delEv <- rmTagButton_ tId pn
351+
pure $ tagNToText <$> delEv
352+
353+
addTag0 <- elClass "form" "form" $ do
354+
el "p" $ text "Tag : "
355+
tagName <- textInput iCfg
356+
tagButton <- button_ "Add Tag"
357+
let tVal = _textInput_value tagName
358+
evAdd = (tagPromptlyDyn tVal tagButton)
359+
addTagN <- holdDyn "" evAdd
360+
addResult <- fmapMaybe reqSuccess <$> putV2PackageTags ((Right . TagN) <$> addTagN) (constDyn $ Right pn) (() <$ evAdd)
361+
pure $ tagPromptlyDyn tVal addResult
362+
pure ()
363+
321364
let evReports' = updated (_dropdown_value ddReports)
322365
dynIdxSt = ddReports ^. dropdown_value
323366

324367
evRepSum <- fmapMaybe reqSuccess <$> getV2PackageReportSummary (constDyn $ Right pn) (Right <$> dynIdxSt) (leftmost [evReports' $> (), ticker4 $> ()])
325368

326369
dynRepSum <- holdUniqDyn =<< holdDyn (PkgIdxTsReport pn (PkgIdxTs 0) [] mempty) evRepSum
327370

328-
329371
el "hr" blank
330372

331373
evCellClick <- reportTableWidget dynRepSum dynQRows dynWorkers dynHist dynInfo
@@ -363,6 +405,8 @@ bodyElement4 = do
363405

364406
unPkgN (PkgN x) = x
365407

408+
unTagN (TagN x) = x
409+
366410
pkgLink pn' = elDynAttr "a" (pkgHref <$> pn') $ dynText (unPkgN <$> pn')
367411

368412
pkgHref (PkgN pn')
@@ -374,6 +418,15 @@ bodyElement4 = do
374418
mergeCellId _ Nothing _ = Nothing
375419
mergeCellId pn (Just (pv,hcv)) is = Just (pn,pv,hcv,is)
376420

421+
rmTagButton_ :: T.Text -> PkgN -> m (Event t TagN)
422+
rmTagButton_ tId pn = do
423+
rmTag <- do
424+
(ev1,_) <- elAttr' "a" ("class" =: "remove") $ do
425+
text " X "
426+
pure $ domEvent Click ev1
427+
delResult <- fmapMaybe reqSuccess <$> deleteV2PackageTags (constDyn $ Right (TagN tId)) (constDyn $ Right pn) rmTag
428+
pure $ (TagN tId) <$ delResult
429+
377430

378431
data FragRoute = RouteHome
379432
| RouteQueue
@@ -405,10 +458,29 @@ decodeFrag frag = case frag of
405458

406459

407460
-- | Renders alpha-tabbed package index
408-
packagesPageWidget :: (MonadHold t m, PostBuild t m, DomBuilder t m) => Dynamic t (Vector PkgN) -> m ()
409-
packagesPageWidget dynPackages = do
461+
packagesPageWidget :: forall t m. (MonadFix m, MonadHold t m, PostBuild t m, DomBuilder t m)
462+
=> Dynamic t (Vector PkgN)
463+
-> Dynamic t (Vector TagN)
464+
-> Dynamic t (Map.Map PkgN [TagN])
465+
-> m ()
466+
packagesPageWidget dynPackages dynTags dynPkgTags = do
410467
display (V.length <$> dynPackages)
411468

469+
dynTags' <- dyn $ do
470+
v <- dynTags
471+
let v' = V.toList v
472+
pure $ do
473+
dynTagSet <- elClass "ol" "tag-filter clearfix" $ do
474+
result <- forM v' $ \(tn) -> do
475+
(ev1, _) <- el "li" $
476+
elAttr' "a" ("class" =: "tag-item") $ do
477+
text (tagNToText tn)
478+
pure $ tn <$ (domEvent Click ev1)
479+
pure $ leftmost result
480+
foldDyn toggleTagSet Set.empty dynTagSet
481+
dynSet' <- holdDyn (constDyn Set.empty) dynTags'
482+
let dynSet = join dynSet'
483+
412484
dynPF <- el "div" $ do
413485
text "[ "
414486
eButton0 <- button "0-9"
@@ -418,24 +490,32 @@ packagesPageWidget dynPackages = do
418490
button (T.singleton c)
419491

420492
text " ]"
421-
422493
holdDyn 'A' (leftmost [ e $> c | (e,c) <- zip (eButton0:eButtons) ('*':['A'..'Z']) ])
423494

424495
-- this is faster than simpleList
425496
_ <- dyn $ do v <- dynPackages
426497
pf <- dynPF
427-
let v' = V.toList . evalPkgFilter pf $ v
498+
st <- dynSet
499+
dpt <- dynPkgTags
500+
let v' = V.toList . (evalTagFilter st dpt) . evalPkgFilter pf $ v
428501

429502
pure $ do
430-
el "ol" $ forM_ v' $ \(PkgN pn) -> do
431-
el "li" $ elAttr "a" ("href" =: ("#/package/" <> pn)) $ text pn
503+
504+
el "ol" $ forM_ v' $ \(pn) -> do
505+
el "li" $ elAttr "a" ("href" =: ("#/package/" <> (pkgNToText pn))) $ do
506+
text ((pkgNToText pn) <> " : ")
507+
case Map.lookup pn dpt of
508+
Just tags -> forM tags $ \(tag0) -> elAttr "a" (("class" =: "tag-item") <> ("data-tag-name" =: (tagNToText tag0))) $ text (tagNToText tag0)
509+
Nothing -> pure ([])
432510

433511
pure ()
434512
where
435513
evalPkgFilter '*' = V.takeWhile (\(PkgN t) -> T.head t < 'A')
436514
evalPkgFilter c = V.takeWhile f . V.dropWhile (not . f)
437515
where
438516
f (PkgN x) = let c' = T.head x in c' == c || c' == (C.toLower c)
517+
evalTagFilter st dpt pkg =
518+
V.filter (tagContained st dpt) pkg
439519

440520

441521
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
617697
applyLR (R:xs) ls (r:rs) = r : applyLR xs ls rs
618698
applyLR _ _ _ = error "applyLR"
619699

700+
toggleTagSet :: TagN -> Set.Set TagN -> Set.Set TagN
701+
toggleTagSet tn st = if Set.member tn st then Set.delete tn st else Set.insert tn st
702+
703+
tagContained :: Set.Set TagN -> Map.Map PkgN [TagN] -> PkgN -> Bool
704+
tagContained st pkgTags pkg
705+
| Set.null st = True
706+
| otherwise =
707+
let
708+
tags =
709+
case Map.lookup pkg pkgTags of
710+
Just a -> a
711+
Nothing -> []
712+
in not $ Set.null (Set.fromList tags `Set.intersection` st)
620713

621714

715+
pkgTagList :: (Map.Map TagN (Vector PkgN))
716+
-> (Map.Map PkgN [TagN])
717+
pkgTagList m = Map.fromListWith (List.++) $ do
718+
(k, vs) <- Map.toList m
719+
v <- (V.toList vs)
720+
pure $ (v, [k])
721+
622722
joinE :: forall t m a . (Reflex t, MonadHold t m) => Event t (Event t a) -> m (Event t a)
623723
joinE = fmap switch . hold never
724+
725+
button_ :: forall t m a. (DomBuilder t m, PostBuild t m) => T.Text -> m (Event t ())
726+
button_ t = do
727+
let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
728+
& elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
729+
(e, _) <- element "button" cfg $ text t
730+
pure $ domEvent Click e
731+
732+

‎src-ui.v3/src/PkgId.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
--
77
module PkgId
88
( PkgN(..)
9+
, TagN(..)
910
, pkgNFromText
1011

1112
, Ver
@@ -141,3 +142,6 @@ verToText (Ver x) = T.pack . Ver.showVersion . Ver.makeVersion $ x
141142
-- go (_ : xs) = go xs
142143
-- go _ = fail "could not parse Version"
143144

145+
----------------------------------------------------------------------------
146+
newtype TagN = TagN { tagNToText :: Text }
147+
deriving (Eq,Ord,FromJSON,ToJSON,ToJSONKey,FromJSONKey,FromHttpApiData,ToHttpApiData)

0 commit comments

Comments
 (0)