git.iko.soy/denis
on master help sign in
Tags Api
commita978e5eaf1a2082311b9d0a0df2c9d66b2d24417 authoriko <ilyakooo0@gmail.com> dateSun 12 May 2019, 01:19 (7 years ago) parent401d37e
4 files changed+53−52
compare with master
unifiedsplit
denis/src/Data/Query.hs+34−4 denis/src/Data/Tags/Completions.hs+10−9 denis/src/Data/Tags/Suggestions.hs−24 denis/src/Server/API/Completions.hs+9−15
denis/src/Data/Query.hs+34−4
@@ -56,7 +56,8 @@ module Data.Query (
5656 createUser,
5757 tryActivateToken,
5858 deactivateToken,
59− searchUsers
59+ searchUsers,
60+ searchTags
6061 ) where
6162
6263import Squeal.PostgreSQL
@@ -353,7 +354,7 @@ getChannelPostsQ lim dir uIds tags = getLastPostsQ
353354 Just uIdsQ -> (`in_` uIdsQ)
354355 Nothing -> const $ false
355356
356−getTagsQ :: Query Schema '[] (RowPG (Only String))
357+getTagsQ :: Query Schema params (RowPG (Only String))
357358getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
358359 from (table #posts)
359360
@@ -555,6 +556,29 @@ searchUsersQ = select (
555556 ])
556557 query = tsQuery' (param @1)
557558
559+tagsByFrquencyQ :: Query Schema params '["tag" ::: 'NotNull (PG Text), "count" ::: 'NotNull 'PGint8]
560+tagsByFrquencyQ = select
561+ (#fromOnly `as` #tag :* count #fromOnly `as` #count)
562+ (from (subquery $ getTagsQ `As` #tt) &
563+ groupBy #fromOnly)
564+
565+getNpopularTagsQ :: Limit -> Query Schema param (RowPG (Only Text))
566+getNpopularTagsQ lim = select (#tag `as` #fromOnly)
567+ (from (subquery $ tagsByFrquencyQ `As` #tt) &
568+ orderBy [#count & Desc] &
569+ limit lim)
570+
571+
572+searchTagsQ :: Query Schema (TuplePG (Only Text)) (RowPG (Only Text))
573+searchTagsQ = select (#tag `as` #fromOnly) $
574+ from (subquery (tagsByFrquencyQ `As` #tt)) &
575+ where_ (vector @@ query) &
576+ orderBy [#count & Desc] &
577+ limit 100
578+ where
579+ query = tsQuery' (param @1)
580+ vector = tsVector' #tag
581+
558582tsRankCd
559583 :: Expression schema from grouping params ('NotNull 'PGtext)
560584 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -876,8 +900,9 @@ deleteNamedChannel uId cId = commitedTransactionallyUpdate $ do
876900 _ <- manipulateParams deleteNamedChannelQ (Only cId)
877901 return ()
878902
879−getTags :: StaticPQ [String]
880−getTags = map fromOnly <$> (runQuery getTagsQ >>= getRows)
903+-- Returns n most popular
904+getTags :: Limit -> StaticPQ [String]
905+getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
881906
882907getDialogs
883908 :: UserId
@@ -964,6 +989,11 @@ searchUsers :: T.Text -> StaticPQ [User Faculty]
964989searchUsers query =
965990 map rowToUser <$> (runQueryParams searchUsersQ (Only . queryFromText $ query) >>= getRows)
966991
992+searchTags :: T.Text -> StaticPQ [Text]
993+searchTags query = map fromOnly <$>
994+ (runQueryParams searchTagsQ
995+ (Only . (<> ":*") . T.strip $ query) >>= getRows)
996+
967997createToken :: Token -> StaticPQ ()
968998createToken token = void $ manipulateParams createTokenQ token
969999
denis/src/Data/Tags/Completions.hs+10−9
@@ -18,25 +18,26 @@ import Data.Bifunctor
1818import Data.Maybe
1919import GHC.Generics
2020import Servant.Docs
21+import Data.Char
2122
22−instance ToSample (CompletionTree Char) where
23+instance ToSample CompletionTree where
2324 toSamples _ = singleSample . mkCompletionTree $
2425 ["aa", "aaab", "ba", "b", "bab"]
2526
26−data CompletionTree a = CompletionTreeNode {
27− value :: Maybe [a],
28− subtree :: M.Map a (CompletionTree a)
27+data CompletionTree = CompletionTreeNode {
28+ value :: Maybe String,
29+ subtree :: M.Map Char CompletionTree
2930 } deriving (Show, Generic)
3031
31−instance ToJSON (CompletionTree Char) where
32+instance ToJSON CompletionTree where
3233
33−mkCompletionTree :: (Ord a) => [[a]] -> CompletionTree a
34−mkCompletionTree = mkCompletionTree' . map (\ a -> (a, a)) . sort
34+mkCompletionTree :: [String] -> CompletionTree
35+mkCompletionTree = mkCompletionTree' . map (\ a -> (map toLower a, a)) . sort
3536 where
36− mkCompletionTree' :: (Ord a) => [([a], [a])] -> CompletionTree a
37+ mkCompletionTree' :: [(String, String)] -> CompletionTree
3738 mkCompletionTree' = uncurry CompletionTreeNode . bimap listToMaybe (M.map mkCompletionTree' . M.fromList) .
3839 second (map (\ u@((k,_):_) -> (k, map snd u)) . groupBy ((==) `on` fst)) . partitionEithers . map processGroup
3940 where
40− processGroup :: ([a], [a]) -> Either [a] (a, ([a], [a]))
41+ processGroup :: (String, String) -> Either String (Char, (String, String))
4142 processGroup ([], b) = Left b
4243 processGroup ((k:rest), aa) = Right (k, (rest, aa))
denis/src/Data/Tags/Suggestions.hsdeleted−24
@@ -1,24 +0,0 @@
1−{-# LANGUAGE
2− LambdaCase,
3− FlexibleInstances,
4− OverloadedStrings #-}
5−{-# OPTIONS_GHC -Wno-orphans #-}
6−
7−module Data.Tags.Suggestions (
8− suggestTags
9− ) where
10−
11−import qualified Data.Text as T
12−import Servant.Docs
13−import Data.List
14−
15−instance {-# Overlapping #-} ToSample [T.Text] where
16− toSamples _ = singleSample ["machineLearning", "cs"]
17−
18−suggestTags :: T.Text -> [T.Text]
19−suggestTags t =
20− let
21− ws = T.words t
22− l = length ws
23− indecies = take (3 + (l `mod` 3)) . map (`mod` l) $ [8849, 11161, 12647, 14081, 16267]
24− in nub . map (ws !!) $ indecies
denis/src/Server/API/Completions.hs+9−15
@@ -18,11 +18,7 @@ import Data.Tags.Completions
1818import Server.App
1919import Data.Connection
2020import Data.Query
21−import qualified Data.Text as T
22−import qualified Data.Post as P
23−import Data.PostElement
24−import Data.Tags.Suggestions
25−import Data.List
21+import Data.Text (Text)
2622
2723type CompletionsDescription = Description "\
2824 \Gets tag completion tree\n\n\
@@ -63,18 +59,16 @@ type CompletionsDescription = Description "\
6359 \}\n\
6460 \```"
6561
66−type SuggestionDescription = Description "Retuens suggested tags for given post element objects."
62+type SearchDescription = Description "Returns tag completions for given user input."
6763
68−type TagsAPI = "completions" :> CompletionsDescription :> Get '[JSON] (CompletionTree Char)
69− :<|> "suggest" :> SuggestionDescription :> ReqBody '[JSON] [PostElement P.Post] :> Post '[JSON] [T.Text]
64+type TagsAPI = "completions" :> CompletionsDescription :> Get '[JSON] CompletionTree :<|>
65+ "search" :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [Text]
7066
7167tagsServer :: ServerT TagsAPI App
72−tagsServer = completionHandler :<|> suggestionHandler
68+tagsServer = completionHandler :<|> tagSearch
7369
74−completionHandler :: App (CompletionTree Char)
75−completionHandler = runQerror $ mkCompletionTree <$> getTags
70+completionHandler :: App CompletionTree
71+completionHandler = runQerror $ mkCompletionTree <$> getTags 1000
7672
77−suggestionHandler :: [PostElement P.Post] -> App [T.Text]
78−suggestionHandler = return . suggestTags . T.concat . intersperse " " . concatMap (\case
79− Markdown t -> T.words t
80− _ -> [])
73+tagSearch :: Text -> App [Text]
74+tagSearch = runQerror . searchTags