be4e284 · denis · git.iko.soy

git.iko.soy/denis

Added completion tree endpoint

Resolved #6

commitbe4e2848fe063b93b7fcaa80a020e46b57d89ad6 authoriko <ilyakooo0@gmail.com> dateSun 28 Apr 2019, 14:32 (7 years ago) parentdede69b

5 files changed+122−5

compare with master

unifiedsplit

denis/src/Data/Completions.hs+42 denis/src/Data/Connection.hs+2−2 denis/src/Data/Query.hs+7−1 denis/src/Server/API.hs+5−2 denis/src/Server/API/Completions.hs+66

denis/src/Data/Completions.hsnew file+42

@@ -0,0 +1,42 @@

1+{-# LANGUAGE

2+ TupleSections,

3+ DeriveGeneric,

4+ FlexibleInstances #-}

5+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

7+module Data.Completions (

8+ CompletionTree(..),

9+ mkCompletionTree

10+ ) where

11+

12+import qualified Data.Map as M

13+import Data.Aeson

14+import Data.List

15+import Data.Function

16+import Data.Either

17+import Data.Bifunctor

18+import Data.Maybe

19+import GHC.Generics

20+import Servant.Docs

21+

22+instance ToSample (CompletionTree Char) where

23+ toSamples _ = singleSample . mkCompletionTree $

24+ ["aa", "aaab", "ba", "b", "bab"]

25+

26+data CompletionTree a = CompletionTreeNode {

27+ value :: Maybe [a],

28+ subtree :: M.Map a (CompletionTree a)

29+ } deriving (Show, Generic)

30+

31+instance ToJSON (CompletionTree Char) where

32+

33+mkCompletionTree :: (Ord a) => [[a]] -> CompletionTree a

34+mkCompletionTree = mkCompletionTree' . map (\ a -> (a, a)) . sort

35+ where

36+ mkCompletionTree' :: (Ord a) => [([a], [a])] -> CompletionTree a

37+ mkCompletionTree' = uncurry CompletionTreeNode . bimap listToMaybe (M.map mkCompletionTree' . M.fromList) .

38+ second (map (\ u@((k,_):_) -> (k, map snd u)) . groupBy ((==) `on` fst)) . partitionEithers . map processGroup

39+ where

40+ processGroup :: ([a], [a]) -> Either [a] (a, ([a], [a]))

41+ processGroup ([], b) = Left b

42+ processGroup ((k:rest), aa) = Right (k, (rest, aa))

denis/src/Data/Connection.hs+2−2

@@ -33,7 +33,7 @@ type StaticPQ = PoolPQ Schema Handler

3333

3434

3535runQ :: ServantErr -> StaticPQ a -> App a

36−runQ err req = handleSqueal (const $ throwError err) $ asks getPool >>= lift . runPoolPQ req

36+runQ err req = handleSqueal ((>> throwError err) . liftIO . print) $ asks getPool >>= lift . runPoolPQ req

3737

3838runQ' :: DBConnection -> ServantErr -> StaticPQ a -> Handler a

3939runQ' conn err req = handleSqueal (const $ throwError err) $ runPoolPQ req conn

@@ -53,6 +53,6 @@ maybeInvalidToken :: App (Maybe a) -> App a

5353maybeInvalidToken = (>>= (\t -> case t of

5454 Just y -> return y

5555 Nothing -> throwError invalidToken))

56−

56+

5757commitedTransactionallyUpdate :: (MonadBaseControl IO tx, MonadPQ schema tx) => tx x -> tx x

5858commitedTransactionallyUpdate = transactionally $ TransactionMode ReadCommitted ReadWrite NotDeferrable

denis/src/Data/Query.hs+7−1

@@ -30,7 +30,8 @@ module Data.Query (

3030 deleteNamedChannel,

3131 HasUsers(..),

3232 wrapIntoUsers,

33− ResponseWithUsers(..)

33+ ResponseWithUsers(..),

34+ getTags

3435) where

3536

3637import Squeal.PostgreSQL

@@ -226,6 +227,9 @@ getChannelPostsQ lim uIds tags = selectStar $ from (subquery $ postsQ' `As` #bar

226227 Nothing -> id

227228 postsQ' = unionWithUsers $ getPostQ id $ where_ $ jsonbLit tags .?| #postRowTags

228229

230+getTagsQ :: Query Schema '[] (RowPG (Only String))

231+getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $

232+ from (table #posts)

229233

230234-- MARK: FrontEnd Data Structures

231235

@@ -347,6 +351,8 @@ deleteNamedChannel uId cId = commitedTransactionallyUpdate $ do

347351 _ <- manipulateParams deleteNamedChannelQ (Only cId)

348352 return ()

349353

354+getTags :: StaticPQ [String]

355+getTags = map fromOnly <$> (runQuery getTagsQ >>= getRows)

350356

351357-- MARK: Utils

352358

denis/src/Server/API.hs+5−2

@@ -27,6 +27,7 @@ import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))

2727import Server.API.Channels

2828import Control.Lens

2929import Server.Query.ComplexQuery

30+import Server.API.Completions

3031

3132-- MARK: Documentation

3233

@@ -48,7 +49,8 @@ type API =

4849 "users" :> "all" :> Post '[JSON] [User] :<|>

4950 "posts" :> PostApi :<|>

5051 "channels" :> ChannelsApi

51− )

52+ ) :<|>

53+ CompletionsAPI

5254

5355serverProxy :: Proxy API

5456serverProxy = Proxy

@@ -62,4 +64,5 @@ mkServerAPI l =

6264 runQnotFound getAllUsers :<|>

6365 postApi uId :<|>

6466 channelsApi uId

65− )

67+ ) :<|>

68+ completionServer

denis/src/Server/API/Completions.hsnew file+66

@@ -0,0 +1,66 @@

1+{-# LANGUAGE

2+ DataKinds ,

3+ DeriveGeneric ,

4+ OverloadedLabels,

5+ OverloadedStrings ,

6+ TypeApplications ,

7+ TypeOperators #-}

9+module Server.API.Completions (

10+ CompletionsAPI,

11+ completionServer

12+ ) where

13+

14+import Servant.Server

15+import Servant

16+import Data.Completions

17+import Server.App

18+import Data.Connection

19+import Data.Query

20+

21+type CompletionsDescription = Description "\

22+ \Gets tag completion tree\n\n\

23+ \```haskell\n\

24+ \data CompletionTree = CompletionTreeNode {\n\

25+ \ value :: Maybe String,\n\

26+ \ subtree :: Map Char CompletionTree\n\

27+ \}\n\

28+ \```\n\n\

29+ \The psuedocode for retrieving all completions from the tree:\n\n\

30+ \```swift\n\

31+ \func getCompletion(tree: CompletionTree, word: String) -> [String] {\n\

32+ \ if word == \"\" {\n\

33+ \ return getValues(tree: tree)\n\

34+ \ }\n\

35+ \\n\

36+ \ let character = word.first\n\

37+ \\n\

38+ \ if tree.subtree[character] == null {\n\

39+ \ return []\n\

40+ \ } else {\n\

41+ \ return getCompletion(tree: tree.subtree[character], word.withoutFirst)\n\

42+ \ }\n\

43+ \}\n\

44+ \\n\

45+ \func getValues(tree: CompletionTree) -> [String] {\n\

46+ \ var out = []\n\

47+ \\n\

48+ \ if tree.value != null {\n\

49+ \ out += tree.value\n\

50+ \ }\n\

51+ \\n\

52+ \ for (key, subtree) in tree {\n\

53+ \ out += getValues(tree: tree)\n\

54+ \ }\n\

55+ \\n\

56+ \ return out\n\

57+ \}\n\

58+ \```"

59+

60+type CompletionsAPI = "tagCompletions" :> CompletionsDescription :> Get '[JSON] (CompletionTree Char)

61+

62+completionServer :: ServerT CompletionsAPI App

63+completionServer = completionHandler

64+

65+completionHandler :: ServerT CompletionsAPI App

66+completionHandler = runQerror $ mkCompletionTree <$> getTags