From ff1adf35eaf48422405905694047dcfd2b4cd056 Mon Sep 17 00:00:00 2001 From: Andika Demas Riyandi Date: Mon, 3 Jun 2019 00:23:24 +0700 Subject: [PATCH 1/3] adding tagging feature to UI version 3 --- src-ui.v3/patch | 171 +++++++++++++++++++++++++++++++++++++++++ src-ui.v3/src/API.hs | 19 ++++- src-ui.v3/src/Main.hs | 118 +++++++++++++++++++++++++--- src-ui.v3/src/PkgId.hs | 4 + 4 files changed, 301 insertions(+), 11 deletions(-) create mode 100644 src-ui.v3/patch diff --git a/src-ui.v3/patch b/src-ui.v3/patch new file mode 100644 index 0000000..b005851 --- /dev/null +++ b/src-ui.v3/patch @@ -0,0 +1,171 @@ +commit f3840712e3afcc0b804390c7b3b79ef6d84a850e +Author: Andika Demas Riyandi +Date: Tue May 28 16:19:12 2019 +0700 + + Adding a working tag list + +diff --git a/src-ui.v3/src/API.hs b/src-ui.v3/src/API.hs +index c7a937d..b23462b 100644 +--- a/src-ui.v3/src/API.hs ++++ b/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 PkgN TagN)) () ++ , 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 "" PkgN :> Capture "" TagN :> PutNoContent '[JSON] NoContent) ++ -- , deleteV2PackageTags :: Client t m (Capture "" PkgN :> Capture "" TagN :> DeleteNoContent '[JSON] NoContent) + + , getV2UnitInfo :: Client t m (Capture "" UUID :> Get '[JSON] UnitIdInfo) () + +@@ -101,6 +107,12 @@ mkClientFuns burl = ClientFuns {..} + :<|> getV2PackageReports + :<|> getV2PackageReportSummary + :<|> getV2PackageReportDetail ++ -- :<|> getV2PackageTags ++ :<|> getV2TagsWithPackage ++ :<|> getV2TagsWithoutPackage ++ -- :<|> getV2TagPackages ++ -- :<|> putV2PackageTags ++ -- :<|> deleteV2PackageTags + :<|> getV2UnitInfo + :<|> getV2Workers + :<|> getV2WorkersPkg +@@ -119,7 +131,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 PkgN TagN) ++ :<|> "v2" :> "tags" :> QueryParam "pkgnames" Bool :> Get '[JSON] (Vector TagN) ++ -- :<|> "v2" :> "tags" :> Capture "tagname" TagN :> Get '[JSON] (Vector PkgN) ++ -- :<|> "v2" :> "tags" :> Capture "pkgname" PkgN :> Capture "tagname" TagN :> PutNoContent '[JSON] NoContent ++ -- :<|> "v2" :> "tags" :> Capture "pkgname" PkgN :> Capture "tagname" TagN :> DeleteNoContent '[JSON] NoContent + :<|> "v2" :> "units" :> Capture "unitid" UUID :> Get '[JSON] UnitIdInfo + + :<|> "v2" :> "workers" :> Get '[JSON] (Vector WorkerRow) +diff --git a/src-ui.v3/src/Main.hs b/src-ui.v3/src/Main.hs +index 4996817..0569113 100644 +--- a/src-ui.v3/src/Main.hs ++++ b/src-ui.v3/src/Main.hs +@@ -41,8 +41,10 @@ import Reflex.Dom.Contrib.Router (route) + import Reflex.Dom.Location + -- import Reflex.Dom.Routing.Nested + import Control.Lens ++import Control.Monad.Fix + import Reflex.Dom.Widget.Basic + import Reflex.Time ++import Reflex.Class + import Servant.API + import Servant.Reflex + +@@ -264,7 +266,13 @@ bodyElement4 = do + + RoutePackages -> pure $ do + el "h1" $ text "Packages" +- packagesPageWidget dynPackages0 ++ evPB <- getPostBuild ++ evTagsOnly <- fmapMaybe reqSuccess <$> getV2TagsWithoutPackage (constDyn $ QParamSome False) evPB ++ dynTagsOnly <- holdDyn mempty evTagsOnly ++ evPkgsTags <- fmapMaybe reqSuccess <$> getV2TagsWithPackage (constDyn $ QParamSome True) evPB ++ dynPkgsTags <- holdDyn Map.empty evPkgsTags ++ ++ packagesPageWidget dynPackages0 dynTagsOnly dynPkgsTags + + RoutePackage pn -> pure $ do + el "h2" $ text (unPkgN pn) +@@ -275,7 +283,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 +@@ -363,6 +371,8 @@ bodyElement4 = do + + unPkgN (PkgN x) = x + ++ unTagN (TagN x) = x ++ + pkgLink pn' = elDynAttr "a" (pkgHref <$> pn') $ dynText (unPkgN <$> pn') + + pkgHref (PkgN pn') +@@ -405,10 +415,26 @@ 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 :: (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 dynPkgsTags = do + display (V.length <$> dynPackages) + ++ dynTags' <- dyn $ do ++ v <- dynTags ++ let v' = V.toList v ++ pure $ do ++ dynTagSet <- elClass "ol" "tag-filter clearfix" $ do ++ forM_ v' $ \(TagN tn) -> do ++ el "li" $ ++ elAttr "a" ("class" =: "tag-item") $ text tn ++ pure $ leftmost $ fmap (\x -> x <$ never) v' ++ foldDyn mkTagSet Set.empty dynTagSet ++ --text dynTags' ++ + dynPF <- el "div" $ do + text "[ " + eButton0 <- button "0-9" +@@ -418,12 +444,12 @@ 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 ++ --tf <- dynTags' + let v' = V.toList . evalPkgFilter pf $ v + + pure $ do +@@ -617,7 +643,8 @@ 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" + +- ++mkTagSet :: TagN -> Set.Set TagN -> Set.Set TagN ++mkTagSet tn st = if Set.member tn st then Set.insert tn st else Set.delete tn st + + joinE :: forall t m a . (Reflex t, MonadHold t m) => Event t (Event t a) -> m (Event t a) + joinE = fmap switch . hold never +diff --git a/src-ui.v3/src/PkgId.hs b/src-ui.v3/src/PkgId.hs +index 2c768b3..479d687 100644 +--- a/src-ui.v3/src/PkgId.hs ++++ b/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) diff --git a/src-ui.v3/src/API.hs b/src-ui.v3/src/API.hs index c7a937d..910d59c 100644 --- a/src-ui.v3/src/API.hs +++ b/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) () @@ -101,6 +107,12 @@ mkClientFuns burl = ClientFuns {..} :<|> getV2PackageReports :<|> getV2PackageReportSummary :<|> getV2PackageReportDetail + :<|> getV2PackageTags + :<|> getV2TagsWithPackage + :<|> getV2TagsWithoutPackage + -- :<|> getV2TagPackages + :<|> putV2PackageTags + :<|> deleteV2PackageTags :<|> getV2UnitInfo :<|> getV2Workers :<|> getV2WorkersPkg @@ -119,7 +131,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) diff --git a/src-ui.v3/src/Main.hs b/src-ui.v3/src/Main.hs index 4996817..ca4338b 100644 --- a/src-ui.v3/src/Main.hs +++ b/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,7 +21,9 @@ 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.Proxy import qualified Data.Set as Set @@ -41,8 +44,10 @@ import Reflex.Dom.Contrib.Router (route) import Reflex.Dom.Location -- import Reflex.Dom.Routing.Nested import Control.Lens +import Control.Monad.Fix import Reflex.Dom.Widget.Basic import Reflex.Time +import Reflex.Class import Servant.API import Servant.Reflex @@ -264,7 +269,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 +286,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 +295,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) <$> @@ -317,7 +331,33 @@ bodyElement4 = do _ <- putV2Queue (constDyn $ Right pn) (Right <$> _dropdown_value tmp) (constDyn $ Right (QEntryUpd (-1))) evQButton pure tmp - + + evTagging <- dyn $ do + v <- dynPkgTags + let v' = V.toList v + inputAttr = ("class" =: "tag-name") <> ("placeholder" =: "insert tag") + cfg = TextInputConfig "tag-name" "" never (constDyn inputAttr) + pure $ do + rmTag <- elClass "p" "tagging" $ do + clickTag <- elClass "ul" "tags" $ do + forM v' $ \(tn) -> do + (ev1, _) <- el "li" $ do + el "span" $ text (tagNToText tn) + elAttr' "a" ("class" =: "remove") $ do + text "X " + pure $ tn <$ (domEvent Click ev1) + pure $ leftmost clickTag + rmTagN <- holdDyn (TagN "") rmTag + _ <- deleteV2PackageTags (Right <$> rmTagN) (constDyn $ Right pn) (() <$ rmTag) + addTag <- elClass "form" "form" $ do + el "p" $ text "Tag : " + tagName <- textInput cfg + tagButton <- button "Add Tag" + pure $ (tagPromptlyDyn (_textInput_value tagName) tagButton) + addTagN <- holdDyn "" addTag + _ <- putV2PackageTags ((Right . TagN) <$> addTagN) (constDyn $ Right pn) evPB + pure () + let evReports' = updated (_dropdown_value ddReports) dynIdxSt = ddReports ^. dropdown_value @@ -363,6 +403,8 @@ bodyElement4 = do unPkgN (PkgN x) = x + unTagN (TagN x) = x + pkgLink pn' = elDynAttr "a" (pkgHref <$> pn') $ dynText (unPkgN <$> pn') pkgHref (PkgN pn') @@ -405,10 +447,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,17 +479,23 @@ 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 @@ -436,6 +503,8 @@ packagesPageWidget dynPackages = do 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 +686,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 + +tagButton :: forall t m. (DomBuilder t m, PostBuild t m) + => TagN + -> m (Event t TagN) +tagButton tn = do + (ev1,_) <- el "li" $ + elAttr' "a" (("class" =: "tag-item") <> ("data-tag-item" =: (tagNToText tn))) $ do + text (tagNToText tn) + pure $ tn <$ (domEvent Click ev1) + +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 diff --git a/src-ui.v3/src/PkgId.hs b/src-ui.v3/src/PkgId.hs index 2c768b3..479d687 100644 --- a/src-ui.v3/src/PkgId.hs +++ b/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) From 099b1d8c7f4055eb55d993d30531db313089e47d Mon Sep 17 00:00:00 2001 From: Andika Demas Riyandi Date: Mon, 3 Jun 2019 14:49:34 +0700 Subject: [PATCH 2/3] fixing adding and removing tag --- src-ui.v3/src/API.hs | 5 +++- src-ui.v3/src/Main.hs | 54 +++++++++++++++++++++++-------------------- 2 files changed, 33 insertions(+), 26 deletions(-) diff --git a/src-ui.v3/src/API.hs b/src-ui.v3/src/API.hs index 910d59c..eabdbbb 100644 --- a/src-ui.v3/src/API.hs +++ b/src-ui.v3/src/API.hs @@ -93,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 @@ -117,7 +120,7 @@ mkClientFuns burl = ClientFuns {..} :<|> 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 diff --git a/src-ui.v3/src/Main.hs b/src-ui.v3/src/Main.hs index ca4338b..6d76fa0 100644 --- a/src-ui.v3/src/Main.hs +++ b/src-ui.v3/src/Main.hs @@ -320,44 +320,48 @@ 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 - evTagging <- dyn $ do + rmTag <- elClass "p" "tagging" $ dyn $ do v <- dynPkgTags let v' = V.toList v - inputAttr = ("class" =: "tag-name") <> ("placeholder" =: "insert tag") - cfg = TextInputConfig "tag-name" "" never (constDyn inputAttr) pure $ do - rmTag <- elClass "p" "tagging" $ do - clickTag <- elClass "ul" "tags" $ do - forM v' $ \(tn) -> do - (ev1, _) <- el "li" $ do - el "span" $ text (tagNToText tn) - elAttr' "a" ("class" =: "remove") $ do - text "X " - pure $ tn <$ (domEvent Click ev1) - pure $ leftmost clickTag - rmTagN <- holdDyn (TagN "") rmTag - _ <- deleteV2PackageTags (Right <$> rmTagN) (constDyn $ Right pn) (() <$ rmTag) - addTag <- elClass "form" "form" $ do - el "p" $ text "Tag : " - tagName <- textInput cfg - tagButton <- button "Add Tag" - pure $ (tagPromptlyDyn (_textInput_value tagName) tagButton) - addTagN <- holdDyn "" addTag - _ <- putV2PackageTags ((Right . TagN) <$> addTagN) (constDyn $ Right pn) evPB - pure () - + clickTag <- elClass "ul" "tags" $ do + forM v' $ \(tn) -> do + (ev1, _) <- el "li" $ do + el "span" $ text (tagNToText tn) + elAttr' "a" ("class" =: "remove") $ do + text " X " + pure $ tn <$ (domEvent Click ev1) + let evTag = leftmost clickTag + rmTagN <- holdDyn (TagN "") evTag + + _ <- deleteV2PackageTags (Right <$> rmTagN) (constDyn $ Right pn) (() <$ evTag) + pure $ rmTagN + + addTag <- elClass "form" "form" $ do + el "p" $ text "Tag : " + tagName <- textInput iCfg + tagButton <- button "Add Tag" + let evAdd = (tagPromptlyDyn (_textInput_value tagName) tagButton) + addTagN <- holdDyn "" evAdd + + _ <- putV2PackageTags ((Right . TagN) <$> addTagN) (constDyn $ Right pn) (() <$ evAdd) + pure $ addTagN + let evReports' = updated (_dropdown_value ddReports) dynIdxSt = ddReports ^. dropdown_value From d4ebff638c279eb04e906c0c4f872b3abdf38e6d Mon Sep 17 00:00:00 2001 From: Andika Demas Riyandi Date: Tue, 11 Jun 2019 13:01:16 +0700 Subject: [PATCH 3/3] Fixing bug on tagging: basic auth, url changes, and add/remove without refresh --- src-ui.v3/patch | 171 ------------------------------------------ src-ui.v3/src/Main.hs | 85 +++++++++++---------- 2 files changed, 46 insertions(+), 210 deletions(-) delete mode 100644 src-ui.v3/patch diff --git a/src-ui.v3/patch b/src-ui.v3/patch deleted file mode 100644 index b005851..0000000 --- a/src-ui.v3/patch +++ /dev/null @@ -1,171 +0,0 @@ -commit f3840712e3afcc0b804390c7b3b79ef6d84a850e -Author: Andika Demas Riyandi -Date: Tue May 28 16:19:12 2019 +0700 - - Adding a working tag list - -diff --git a/src-ui.v3/src/API.hs b/src-ui.v3/src/API.hs -index c7a937d..b23462b 100644 ---- a/src-ui.v3/src/API.hs -+++ b/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 PkgN TagN)) () -+ , 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 "" PkgN :> Capture "" TagN :> PutNoContent '[JSON] NoContent) -+ -- , deleteV2PackageTags :: Client t m (Capture "" PkgN :> Capture "" TagN :> DeleteNoContent '[JSON] NoContent) - - , getV2UnitInfo :: Client t m (Capture "" UUID :> Get '[JSON] UnitIdInfo) () - -@@ -101,6 +107,12 @@ mkClientFuns burl = ClientFuns {..} - :<|> getV2PackageReports - :<|> getV2PackageReportSummary - :<|> getV2PackageReportDetail -+ -- :<|> getV2PackageTags -+ :<|> getV2TagsWithPackage -+ :<|> getV2TagsWithoutPackage -+ -- :<|> getV2TagPackages -+ -- :<|> putV2PackageTags -+ -- :<|> deleteV2PackageTags - :<|> getV2UnitInfo - :<|> getV2Workers - :<|> getV2WorkersPkg -@@ -119,7 +131,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 PkgN TagN) -+ :<|> "v2" :> "tags" :> QueryParam "pkgnames" Bool :> Get '[JSON] (Vector TagN) -+ -- :<|> "v2" :> "tags" :> Capture "tagname" TagN :> Get '[JSON] (Vector PkgN) -+ -- :<|> "v2" :> "tags" :> Capture "pkgname" PkgN :> Capture "tagname" TagN :> PutNoContent '[JSON] NoContent -+ -- :<|> "v2" :> "tags" :> Capture "pkgname" PkgN :> Capture "tagname" TagN :> DeleteNoContent '[JSON] NoContent - :<|> "v2" :> "units" :> Capture "unitid" UUID :> Get '[JSON] UnitIdInfo - - :<|> "v2" :> "workers" :> Get '[JSON] (Vector WorkerRow) -diff --git a/src-ui.v3/src/Main.hs b/src-ui.v3/src/Main.hs -index 4996817..0569113 100644 ---- a/src-ui.v3/src/Main.hs -+++ b/src-ui.v3/src/Main.hs -@@ -41,8 +41,10 @@ import Reflex.Dom.Contrib.Router (route) - import Reflex.Dom.Location - -- import Reflex.Dom.Routing.Nested - import Control.Lens -+import Control.Monad.Fix - import Reflex.Dom.Widget.Basic - import Reflex.Time -+import Reflex.Class - import Servant.API - import Servant.Reflex - -@@ -264,7 +266,13 @@ bodyElement4 = do - - RoutePackages -> pure $ do - el "h1" $ text "Packages" -- packagesPageWidget dynPackages0 -+ evPB <- getPostBuild -+ evTagsOnly <- fmapMaybe reqSuccess <$> getV2TagsWithoutPackage (constDyn $ QParamSome False) evPB -+ dynTagsOnly <- holdDyn mempty evTagsOnly -+ evPkgsTags <- fmapMaybe reqSuccess <$> getV2TagsWithPackage (constDyn $ QParamSome True) evPB -+ dynPkgsTags <- holdDyn Map.empty evPkgsTags -+ -+ packagesPageWidget dynPackages0 dynTagsOnly dynPkgsTags - - RoutePackage pn -> pure $ do - el "h2" $ text (unPkgN pn) -@@ -275,7 +283,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 -@@ -363,6 +371,8 @@ bodyElement4 = do - - unPkgN (PkgN x) = x - -+ unTagN (TagN x) = x -+ - pkgLink pn' = elDynAttr "a" (pkgHref <$> pn') $ dynText (unPkgN <$> pn') - - pkgHref (PkgN pn') -@@ -405,10 +415,26 @@ 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 :: (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 dynPkgsTags = do - display (V.length <$> dynPackages) - -+ dynTags' <- dyn $ do -+ v <- dynTags -+ let v' = V.toList v -+ pure $ do -+ dynTagSet <- elClass "ol" "tag-filter clearfix" $ do -+ forM_ v' $ \(TagN tn) -> do -+ el "li" $ -+ elAttr "a" ("class" =: "tag-item") $ text tn -+ pure $ leftmost $ fmap (\x -> x <$ never) v' -+ foldDyn mkTagSet Set.empty dynTagSet -+ --text dynTags' -+ - dynPF <- el "div" $ do - text "[ " - eButton0 <- button "0-9" -@@ -418,12 +444,12 @@ 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 -+ --tf <- dynTags' - let v' = V.toList . evalPkgFilter pf $ v - - pure $ do -@@ -617,7 +643,8 @@ 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" - -- -+mkTagSet :: TagN -> Set.Set TagN -> Set.Set TagN -+mkTagSet tn st = if Set.member tn st then Set.insert tn st else Set.delete tn st - - joinE :: forall t m a . (Reflex t, MonadHold t m) => Event t (Event t a) -> m (Event t a) - joinE = fmap switch . hold never -diff --git a/src-ui.v3/src/PkgId.hs b/src-ui.v3/src/PkgId.hs -index 2c768b3..479d687 100644 ---- a/src-ui.v3/src/PkgId.hs -+++ b/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) diff --git a/src-ui.v3/src/Main.hs b/src-ui.v3/src/Main.hs index 6d76fa0..a2b3236 100644 --- a/src-ui.v3/src/Main.hs +++ b/src-ui.v3/src/Main.hs @@ -25,6 +25,7 @@ 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 @@ -39,11 +40,12 @@ 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 @@ -335,33 +337,30 @@ bodyElement4 = do pure tmp - rmTag <- elClass "p" "tagging" $ dyn $ do - v <- dynPkgTags - let v' = V.toList v - pure $ do - clickTag <- elClass "ul" "tags" $ do - forM v' $ \(tn) -> do - (ev1, _) <- el "li" $ do - el "span" $ text (tagNToText tn) - elAttr' "a" ("class" =: "remove") $ do - text " X " - pure $ tn <$ (domEvent Click ev1) - let evTag = leftmost clickTag - rmTagN <- holdDyn (TagN "") evTag - - _ <- deleteV2PackageTags (Right <$> rmTagN) (constDyn $ Right pn) (() <$ evTag) - pure $ rmTagN - - addTag <- elClass "form" "form" $ do - el "p" $ text "Tag : " - tagName <- textInput iCfg - tagButton <- button "Add Tag" - let evAdd = (tagPromptlyDyn (_textInput_value tagName) tagButton) - addTagN <- holdDyn "" evAdd - - _ <- putV2PackageTags ((Right . TagN) <$> addTagN) (constDyn $ Right pn) (() <$ evAdd) - pure $ addTagN - + 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 @@ -369,7 +368,6 @@ bodyElement4 = do dynRepSum <- holdUniqDyn =<< holdDyn (PkgIdxTsReport pn (PkgIdxTs 0) [] mempty) evRepSum - el "hr" blank evCellClick <- reportTableWidget dynRepSum dynQRows dynWorkers dynHist dynInfo @@ -420,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 @@ -693,15 +700,6 @@ 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 -tagButton :: forall t m. (DomBuilder t m, PostBuild t m) - => TagN - -> m (Event t TagN) -tagButton tn = do - (ev1,_) <- el "li" $ - elAttr' "a" (("class" =: "tag-item") <> ("data-tag-item" =: (tagNToText tn))) $ do - text (tagNToText tn) - pure $ tn <$ (domEvent Click ev1) - tagContained :: Set.Set TagN -> Map.Map PkgN [TagN] -> PkgN -> Bool tagContained st pkgTags pkg | Set.null st = True @@ -723,3 +721,12 @@ pkgTagList m = Map.fromListWith (List.++) $ do 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 + +