@@ -12,11 +12,10 @@ import Control.Lens
1212import Control.Lens.Extras
1313import Control.Monad
1414import Control.Monad.IO.Class
15−import Data.Coerce
1615import Data.Generics.Product (field)
1716import Data.Generics.Sum (_Ctor)
18−import Data.List as L (filter, null, partition, sortBy)
19−import Data.Text as T (Text, isPrefixOf, toCaseFold)
17+import qualified Data.List as L
18+import Data.Text (Text)
2019import Data.Time (diffUTCTime, getCurrentTime)
2120import GHC.Generics (Generic)
2221import Obelisk.Route.Frontend
@@ -25,10 +24,14 @@ import Servant.Reflex
2524
2625import Common.Types as CT
2726import Common.Utils
27+import Control.Applicative
2828import Control.Monad.Reader
2929import Data.Align
30+import Data.Char
3031import Data.Functor
3132import qualified Data.Semigroup as S
33+import qualified Data.Text as T
34+import Data.Text.Search
3235import Data.These
3336import Frontend.API
3437import Frontend.GHCJS
@@ -126,7 +129,7 @@ deploymentsHeadWidget enabledSearch okUpdEv =
126129 pure termDyn'
127130 (nsEl, _) <- elClass' "button"
128131 "page__action button button--add popup-handler" $ text "New deployment"
129− pure $ (domEvent Click nsEl, value termDyn)
132+ pure (domEvent Click nsEl, value termDyn)
130133
131134-- ^ Widget that shows how much time has passed since the last update.
132135lastUpdateWidget :: MonadWidget t m => Event t () -> m ()
@@ -174,28 +177,45 @@ deploymentsListWidget updAllEv termDyn ds = dataWidgetWrapper $ mdo
174177 errUpdEv = fmapMaybe reqFailure updRespEv
175178 dsDyn <- holdDyn ds okUpdEv
176179 let
177− isArchived = view (field @"archived")
180+ isArchived = view (field @"deployment" . field @"archived")
178181 filteredDyn = ffor2 termDyn dsDyn $ \term ds' ->
179− L.filter (searchDeployments term) ds'
182+ mapMaybe (searchDeployments . T.filter (not . isSpace) $ term) ds'
180183 (archivedDsDyn, activeDsDyn) = splitDynPure $ L.partition isArchived
181184 <$> filteredDyn
185+ searchSorting = termDyn $> Just (SortDesc (view #score))
182186 clickedEv <- elementClick
183− editEv <- activeDeploymentsWidget clickedEv activeDsDyn
184− archivedDeploymentsWidget clickedEv archivedDsDyn
187+ editEv <- activeDeploymentsWidget searchSorting clickedEv activeDsDyn
188+ archivedDeploymentsWidget searchSorting clickedEv archivedDsDyn
185189 pure (() <$ okUpdEv, () <$ errUpdEv, editEv)
186190
191+data SearchedDeploymentFullInfo = SearchedDeploymentFullInfo
192+ { deployment :: DeploymentFullInfo
193+ , searchResult :: DeploymentSearchResult
194+ , score :: Int
195+ } deriving stock (Generic, Show, Eq)
196+
187197-- | Compares deployment fields (name and tag) with a search term.
188198searchDeployments
189199 :: Text -- ^ Search term.
190200 -> DeploymentFullInfo -- ^ Deployment data.
191− -> Bool
192−searchDeployments "" _ = True
193−searchDeployments term d = term' `isPrefixOf` dname
194− || term' `isPrefixOf` dtag
201+ -> Maybe SearchedDeploymentFullInfo
202+searchDeployments term d = case (tagResult, nameResult) of
203+ (Nothing, Nothing) -> Nothing
204+ (Just (res, score), Nothing) ->
205+ Just $ SearchedDeploymentFullInfo d (DeploymentTagResult res) score
206+ (Nothing, Just (res, score)) ->
207+ Just $ SearchedDeploymentFullInfo d (DeploymentNameResult res) score
208+ (Just (tRes, tScore), Just (nRes, nScore)) -> if tScore > nScore
209+ then Just $ SearchedDeploymentFullInfo d (DeploymentTagResult tRes) tScore
210+ else Just $ SearchedDeploymentFullInfo d (DeploymentNameResult nRes) nScore
195211 where
196− term' = toCaseFold term
197− dtag = d ^. field @"deployment" . field @"tag" . coerced . to toCaseFold
198− dname = d ^. dfiName . coerced . to toCaseFold
212+ tagResult = fuzzySearch term . unDeploymentTag $ d ^. field @"deployment" . field @"tag"
213+ nameResult = fuzzySearch term . unDeploymentName $ d ^. dfiName
214+
215+data DeploymentSearchResult
216+ = DeploymentNameResult [FuzzySearchStringChunk Text]
217+ | DeploymentTagResult [FuzzySearchStringChunk Text]
218+ deriving (Show, Eq)
199219
200220-- | Table with active deployments.
201221activeDeploymentsWidget
@@ -205,19 +225,22 @@ activeDeploymentsWidget
205225 , SetRoute t (R Routes) m
206226 , MonadReader ProjectConfig m
207227 )
208− => Event t ClickedElement
228+ => Dynamic t (Maybe (SortDir SearchedDeploymentFullInfo))
229+ -> Event t ClickedElement
209230 -- ^ Event that carries the clicked DOM element. This event is required by
210231 -- `dropdownWidget'`.
211− -> Dynamic t [DeploymentFullInfo]
232+ -> Dynamic t [SearchedDeploymentFullInfo]
212233 -> m (Event t DeploymentFullInfo)
213234 -- ^ Returns an event carrying editable deployment
214235 -- to \"edit deployment\" sidebar.
215−activeDeploymentsWidget clickedEv dsDyn =
236+activeDeploymentsWidget searchSorting clickedEv dsDyn =
216237 divClass "data__primary" $
217− tableWrapper $ \sortDyn -> do
238+ tableWrapper (updated searchSorting $> SortingChanged) $ \sortDyn -> do
239+ let colSortDyn = fmap (contramap (view #deployment)) <$> sortDyn
240+ sorting <- holdDyn Nothing (mergeWith (<|>) [updated colSortDyn, updated searchSorting])
218241 let
219242 emptyDyn' = L.null <$> dsDyn
220− dsSortedDyn = zipDynWith sortDeployments dsDyn sortDyn
243+ dsSortedDyn = zipDynWith sortDeployments dsDyn sorting
221244 emptyDyn <- holdUniqDyn emptyDyn'
222245 editEvEv <- dyn $ emptyDyn <&> \case
223246 False -> do
@@ -246,21 +269,22 @@ activeDeploymentWidget
246269 => Event t ClickedElement
247270 -- ^ Event that carries the clicked DOM element. This event is required by
248271 -- `dropdownWidget'`.
249− -> Dynamic t (DeploymentFullInfo)
272+ -> Dynamic t SearchedDeploymentFullInfo
250273 -> m (Event t DeploymentFullInfo)
251274 -- ^ Returns event carrying editable deployment
252275 -- that is required by \"edit deployment\" sidebar.
253276activeDeploymentWidget clickedEv dDyn' = do
254277 dDyn <- holdUniqDyn dDyn'
255− editEvEv <- dyn $ ffor dDyn $ \d@DeploymentFullInfo{..} -> do
256− let dname = deployment ^. field @"name"
278+ editEvEv <- dyn $ ffor dDyn $ \s@SearchedDeploymentFullInfo {deployment = d@DeploymentFullInfo{..}} -> do
279+ let
280+ (name, tag') = displaySearchHighlighting s
281+ dName = deployment ^. #name
257282 (linkEl, dropdownEv) <- el' "tr" $ do
258283 el "td" $ do
259− text $ coerce dname
284+ name
260285 statusWidget $ constDyn status
261286 el "td" $ divClass "listing" $ forM_ metadata (renderMetadataLink . pure)
262− el "td" $
263− text $ coerce $ deployment ^. field @"tag"
287+ el "td" tag'
264288 el "td" $
265289 overridesWidget $ deployment ^. field @"appOverrides" . coerced
266290 el "td" $
@@ -274,7 +298,7 @@ activeDeploymentWidget clickedEv dDyn' = do
274298 disabledAttr = if isPending status
275299 then "disabled" =: ""
276300 else mempty
277− elId = "deployment_row_" <> (coerce dname)
301+ elId = "deployment_row_" <> unDeploymentName dName
278302 btn = elAttr "button"
279303 ( "class" =: "drop__handler"
280304 <> "type" =: "button"
@@ -283,7 +307,7 @@ activeDeploymentWidget clickedEv dDyn' = do
283307 body = do
284308 btnEditEv <- buttonClass "action action--edit" "Edit"
285309 btnArcEv <- buttonClass "action action--archive" "Move to archive"
286− url' <- kubeDashboardUrl dDyn
310+ url' <- kubeDashboardUrl (view #deployment <$> dDyn)
287311 void . dyn $ url' <&> maybe blank (\url ->
288312 void $ aButtonClass' "action action--logs" "Details"
289313 (pure $ "href" =: url)
@@ -298,35 +322,56 @@ activeDeploymentWidget clickedEv dDyn' = do
298322 delEv <- confirmArchivePopup archEv $ do
299323 text "Are you sure you want to archive the"
300324 el "br" blank
301− text $ coerce dname <> " deployment?"
302− void $ archiveEndpoint (constDyn $ Right $ dname) delEv
303− let route = DashboardRoute :/ Just dname
325+ text $ unDeploymentName dName <> " deployment?"
326+ void $ archiveEndpoint (constDyn . Right $ dName) delEv
327+ let route = DashboardRoute :/ Just dName
304328 setRoute $ route <$ domEvent Dblclick linkEl
305329 pure editEv
306330 switchHold never editEvEv
307331
332+displaySearchHighlighting :: DomBuilder t m => SearchedDeploymentFullInfo -> (m (), m ())
333+displaySearchHighlighting
334+ SearchedDeploymentFullInfo {searchResult = DeploymentNameResult res, deployment = d} =
335+ ( markMatches res
336+ , text . unDeploymentTag $ d ^. #deployment . #tag
337+ )
338+displaySearchHighlighting
339+ SearchedDeploymentFullInfo {searchResult = DeploymentTagResult res, deployment = d} =
340+ ( text . unDeploymentName $ d ^. #deployment . #name
341+ , markMatches res
342+ )
343+
344+markMatches :: DomBuilder t m => [FuzzySearchStringChunk Text] -> m ()
345+markMatches [] = blank
346+markMatches (NotMatched x : xs) = text x >> markMatches xs
347+markMatches (Matched x : xs) =
348+ elAttr "span" ("style" =: "text-decoration: underline;") (text x) >> markMatches xs
349+
308350-- | Table with archived deployments.
309351archivedDeploymentsWidget
310− ::
352+ :: forall t m.
311353 ( MonadWidget t m
312354 , RouteToUrl (R Routes) m
313355 , SetRoute t (R Routes) m )
314− => Event t ClickedElement
356+ => Dynamic t (Maybe (SortDir SearchedDeploymentFullInfo))
357+ -> Event t ClickedElement
315358 -- ^ Event that carries the clicked DOM element. This event is required by
316359 -- `dropdownWidget'`.
317− -> Dynamic t [DeploymentFullInfo]
360+ -> Dynamic t [SearchedDeploymentFullInfo]
318361 -> m ()
319−archivedDeploymentsWidget clickedEv dsDyn = do
362+archivedDeploymentsWidget searchSorting clickedEv dsDyn = do
320363 showDyn <- toggleButton
321364 let
322365 classDyn = ffor showDyn $ \case
323366 True -> "data__archive data__archive--open"
324367 False -> "data__archive"
325368 elDynClass "div" classDyn $
326− tableWrapper $ \sortDyn -> do
369+ tableWrapper (updated searchSorting $> SortingChanged) $ \sortDyn -> do
370+ let colSortDyn = fmap (contramap (view #deployment)) <$> sortDyn
371+ sorting <- holdDyn Nothing (mergeWith (<|>) [updated colSortDyn, updated searchSorting])
327372 let
328373 emptyDyn' = L.null <$> dsDyn
329− dsSortedDyn = zipDynWith sortDeployments dsDyn sortDyn
374+ dsSortedDyn = zipDynWith sortDeployments dsDyn sorting
330375 emptyDyn <- holdUniqDyn emptyDyn'
331376 dyn_ $ emptyDyn <&> \case
332377 False -> void $ simpleList dsSortedDyn
@@ -340,19 +385,20 @@ archivedDeploymentWidget
340385 , RouteToUrl (R Routes) m
341386 , SetRoute t (R Routes) m )
342387 => Event t ClickedElement
343− -> Dynamic t DeploymentFullInfo
388+ -> Dynamic t SearchedDeploymentFullInfo
344389 -> m ()
345390archivedDeploymentWidget clickedEv dDyn' = do
346391 dDyn <- holdUniqDyn dDyn'
347− dyn_ $ ffor dDyn $ \DeploymentFullInfo{..} -> do
348− let dname = deployment ^. field @"name"
392+ dyn_ $ ffor dDyn $ \s@SearchedDeploymentFullInfo {deployment = DeploymentFullInfo{..}} -> do
393+ let
394+ (name, tag') = displaySearchHighlighting s
395+ dName = deployment ^. #name
349396 (linkEl, _) <- el' "tr" $ do
350397 el "td" $ do
351− text $ coerce dname
398+ name
352399 divClass "status status--archived" $ text "Archived"
353400 el "td" $ text "..."
354− el "td" $
355− text $ coerce $ deployment ^. field @"tag"
401+ el "td" tag'
356402 el "td" $
357403 overridesWidget $ deployment ^. field @"appOverrides" . coerced
358404 el "td" $
@@ -363,7 +409,7 @@ archivedDeploymentWidget clickedEv dDyn' = do
363409 text $ formatPosixToDate updatedAt
364410 el "td" $ do
365411 let
366− elId = "deployment_row_" <> (coerce dname)
412+ elId = "deployment_row_" <> (unDeploymentName dName)
367413 btn = elAttr "button"
368414 ( "class" =: "drop__handler"
369415 <> "type" =: "button"
@@ -373,32 +419,36 @@ archivedDeploymentWidget clickedEv dDyn' = do
373419 "action action--archive" "Restore from archive"
374420 pure btnArcEv
375421 btnEv <- dropdownWidget' clickedEv btn body
376− void $ restoreEndpoint (constDyn $ Right $ dname) btnEv
377− let route = DashboardRoute :/ Just dname
422+ void $ restoreEndpoint (constDyn $ Right $ dName) btnEv
423+ let route = DashboardRoute :/ Just dName
378424 setRoute $ route <$ domEvent Dblclick linkEl
379425
380426-- | Sort deployments by the supplied condition.
381427sortDeployments
382− :: [DeploymentFullInfo]
383− -> Maybe SortDir
428+ :: [SearchedDeploymentFullInfo]
429+ -> Maybe (SortDir SearchedDeploymentFullInfo)
384430 -- ^ Sorting condition.
385− -> [DeploymentFullInfo]
431+ -> [SearchedDeploymentFullInfo]
386432sortDeployments items s = L.sortBy sortFunc items
387433 where
388434 sortFunc a b = case s of
389− Just (SortAsc get) -> compare (a ^. get) (b ^. get)
390− Just (SortDesc get) -> compare (b ^. get) (a ^. get)
435+ Just (SortAsc get) -> compare (get a) (get b)
436+ Just (SortDesc get) -> compare (get b) (get a)
391437 Nothing -> EQ
392438
393439-- | Each constructor contains a getter
394440-- that extracts the field that is used for sorting.
395−data SortDir where
396− SortAsc :: Ord a => Getter DeploymentFullInfo a -> SortDir
397− SortDesc :: Ord a => Getter DeploymentFullInfo a -> SortDir
398− deriving Semigroup via (S.Last SortDir)
441+data SortDir x where
442+ SortAsc :: Ord a => (x -> a) -> SortDir x
443+ SortDesc :: Ord a => (x -> a) -> SortDir x
444+ deriving Semigroup via (S.Last (SortDir x))
445+
446+instance Contravariant SortDir where
447+ contramap f (SortAsc g) = SortAsc $ g . f
448+ contramap f (SortDesc g) = SortDesc $ g . f
399449
400450-- | Sorting toggler.
401−toggleSort :: SortDir -> SortDir
451+toggleSort :: SortDir a -> SortDir a
402452toggleSort = \case
403453 SortAsc x -> SortDesc x
404454 SortDesc x -> SortAsc x
@@ -409,13 +459,13 @@ tableHeader :: (MonadWidget t m, SortableTableGroup t m) => m ()
409459tableHeader = do
410460 el "thead" $
411461 el "tr" $ do
412− sortHeader dfiName "Name" SortAsc
462+ sortHeader (view dfiName) "Name" SortAsc
413463 el "th" $ text "Links"
414464 el "th" $ text "Tag"
415465 el "th" $ text "App overrides"
416466 el "th" $ text "Deployment overrides"
417− sortHeader (field @"createdAt") "Created" SortDesc
418− sortHeaderInitially (field @"updatedAt") "Changed" SortDesc
467+ sortHeader (view $ field @"createdAt") "Created" SortDesc
468+ sortHeaderInitially (view $ field @"updatedAt") "Changed" SortDesc
419469 el "th" $
420470 elClass "span" "visuallyhidden" $ text "Menu"
421471
@@ -424,7 +474,7 @@ data SortingChanged = SortingChanged
424474
425475type SortableTableGroup t m =
426476 ( MonadReader (Event t SortingChanged) m
427− , MultiEventWriter t SortDir m
477+ , MultiEventWriter t (SortDir DeploymentFullInfo) m
428478 , MultiEventWriter t SortingChanged m
429479 )
430480
@@ -432,22 +482,23 @@ type SortableTableGroup t m =
432482-- Makes sure that only one can be active at a time.
433483runSortableTableGroup
434484 :: (Reflex t, MonadFix m)
435− => ReaderT
485+ => Event t SortingChanged
486+ -> ReaderT
436487 (Event t SortingChanged)
437− (EventWriterT t SortDir (EventWriterT t SortingChanged m))
488+ (EventWriterT t (SortDir DeploymentFullInfo) (EventWriterT t SortingChanged m))
438489 x
439− -> m (x, Event t SortDir)
440−runSortableTableGroup m = mdo
490+ -> m (x, Event t (SortDir DeploymentFullInfo))
491+runSortableTableGroup sChanged m = mdo
441492 ((x, sDyn), changed) <-
442− runEventWriterT . runEventWriterT . flip runReaderT changed $ m
493+ runEventWriterT . runEventWriterT . flip runReaderT (leftmost [sChanged, changed]) $ m
443494 return (x, sDyn)
444495
445−type SortingDirection a = Getter DeploymentFullInfo a -> SortDir
496+type SortingDirection a = (DeploymentFullInfo -> a) -> SortDir DeploymentFullInfo
446497
447498-- | Special column header with a sort button.
448499sortHeader
449500 :: forall t m a. (MonadWidget t m, Ord a, SortableTableGroup t m)
450− => Getter DeploymentFullInfo a
501+ => (DeploymentFullInfo -> a)
451502 -> Text
452503 -> SortingDirection a -- ^ The direction to sort when clicked
453504 -> m ()
@@ -457,7 +508,7 @@ sortHeader f l defaultSorting =
457508-- | Special column header with a sort button.
458509sortHeaderInitially
459510 :: forall t m a. (MonadWidget t m, Ord a, SortableTableGroup t m)
460− => Getter DeploymentFullInfo a
511+ => (DeploymentFullInfo -> a)
461512 -> Text
462513 -> SortingDirection a -- ^ The direction to sort when clicked and when the page loads
463514 -> m ()
@@ -467,7 +518,7 @@ sortHeaderInitially f l defaultSorting =
467518-- | Special column header with a sort button.
468519sortHeaderWithInitial
469520 :: forall t m a. (MonadWidget t m, Ord a, SortableTableGroup t m)
470− => Getter DeploymentFullInfo a
521+ => (DeploymentFullInfo -> a)
471522 -> Text
472523 -> SortingDirection a -- ^ The direction to sort when clicked
473524 -> Maybe (SortingDirection a) -- ^ The direction to sort when the page loads
@@ -496,13 +547,14 @@ sortHeaderWithInitial f l defaultSorting initSortingM = do
496547-- | A wrapper that adds a header to the table.
497548tableWrapper
498549 :: (MonadWidget t m)
499− => (Dynamic t (Maybe SortDir) -> m a)
550+ => Event t SortingChanged
551+ -> (Dynamic t (Maybe (SortDir DeploymentFullInfo)) -> m a)
500552 -- ^ Sorting direction is obtained from the table header.
501553 -> m a
502−tableWrapper ma =
554+tableWrapper sChanged ma =
503555 divClass "table table--deployments table--clickable table--double-click" $
504556 el "table" $ mdo
505− ((), sDyn') <- runSortableTableGroup tableHeader
557+ ((), sDyn') <- runSortableTableGroup sChanged tableHeader
506558 sDyn <- holdDyn Nothing $ Just <$> sDyn'
507559 el "tbody" $ ma sDyn
508560
@@ -510,7 +562,7 @@ tableWrapper ma =
510562initTableWrapper :: MonadWidget t m => m () -> m ()
511563initTableWrapper ma = do
512564 divClass "data_primary" $
513− tableWrapper $ const $
565+ tableWrapper never $ const $
514566 emptyTableBody $ ma
515567
516568-- | Widget with a loading spinner.