git.iko.soy/denis
on master help sign in
Resolved #5.
9451b5fiko
denis/docs/Docs.hs+7−3
compare with master
unifiedsplit
@@ -19,15 +19,19 @@ import Data.Word (Word64)
19import Server.API.Posts
19import Server.API.Posts
20import Server.Logger
20import Server.Logger
21import Server.Auth
21import Server.Auth
22+import Server.API.Channels
23+import Data.Aeson
22
24
23docsWriter :: HasDocs api => String -> Proxy api -> IO ()
25docsWriter :: HasDocs api => String -> Proxy api -> IO ()
24docsWriter file = writeFile ("docs/" ++ file ++ ".md") . normalizer . markdown . docs
26docsWriter file = writeFile ("docs/" ++ file ++ ".md") . normalizer . markdown . docs
25
27
26main = do
28main = do
27− docsWriter "posts" (Proxy :: Proxy ("posts" :> PostApi))
29+ docsWriter "posts" $ pretty (Proxy :: Proxy ("posts" :> PostApi))
28− docsWriter "all" serverProxy
30+ docsWriter "all" $ pretty serverProxy
29− docsWriter "authentication" (Proxy :: Proxy ("authentication" :> AuthenticationHandler :<|>
31+ docsWriter "authentication" $ pretty (Proxy :: Proxy ("authentication" :> AuthenticationHandler :<|>
30 Authentication :> "authentication" :> "me" :> Post '[JSON] UserId ))
32 Authentication :> "authentication" :> "me" :> Post '[JSON] UserId ))
33+ docsWriter "channels" $ pretty (Proxy :: Proxy ("channels" :> ChannelsApi))
34+
31
35
32instance ToSample Char where
36instance ToSample Char where
33 toSamples _ = singleSample 'c'
37 toSamples _ = singleSample 'c'
denis/package.yaml+1
@@ -48,6 +48,7 @@ dependencies:
48- wai-extra
48- wai-extra
49- data-default-class
49- data-default-class
50- fast-logger
50- fast-logger
51+- vector
51
52
52- lens
53- lens
53
54
denis/src/Data/Channel/AnonymousChannel.hsnew file+54
@@ -0,0 +1,54 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators,
8+ OverloadedStrings #-}
9+
10+module Data.Channel.AnonymousChannel (
11+ AnonymousChannelId,
12+ AnonymousChannel(..)
13+) where
14+
15+import Data.Int (Int64)
16+import qualified Generics.SOP as SOP
17+import qualified GHC.Generics as GHC
18+import Data.Aeson
19+import Servant.Docs (ToSample, toSamples, samples)
20+import Data.Proxy
21+import Data.Text (Text)
22+import Data.Function (on)
23+import Data.Time.Clock
24+import Data.Time.Calendar
25+import qualified Data.Vector as V
26+import Data.User
27+
28+
29+-- MARK: Documentation
30+
31+instance ToSample AnonymousChannel where
32+ toSamples _ = samples $ AnonymousChannel <$> [V.fromList ["thisIsHashTag", "thisIsAlsoHashTag"]] <*> [[2, 7, 8]]
33+
34+-- MARK: Implementation
35+
36+type AnonymousChannelId = Int64
37+
38+data AnonymousChannel = AnonymousChannel {
39+ anonymousChannelTags :: V.Vector Text,
40+ anonymousChannelPeopleIds :: [UserId]
41+} deriving GHC.Generic
42+
43+instance SOP.Generic AnonymousChannel
44+instance SOP.HasDatatypeInfo AnonymousChannel
45+
46+instance ToJSON AnonymousChannel where
47+ toJSON (AnonymousChannel cTags cPeople) = object [
48+ "tags" .= cTags,
49+ "people" .= cPeople ]
50+
51+instance FromJSON AnonymousChannel where
52+ parseJSON = withObject "anonymous channel" $ \e ->
53+ AnonymousChannel <$> e .: "tags" <*> e .: "people"
54+
denis/src/Data/Channel/NamedChannel.hsnew file+80
@@ -0,0 +1,80 @@
1+{-# LANGUAGE
2+DataKinds ,
3+DeriveGeneric ,
4+OverloadedLabels,
5+OverloadedStrings ,
6+TypeApplications ,
7+TypeOperators,
8+OverloadedStrings #-}
9+
10+module Data.Channel.NamedChannel (
11+ NamedChannelId,
12+ NamedChannel(..),
13+ NamedChannelCreationRequest(..)
14+) where
15+
16+import Data.Int (Int64)
17+import qualified Generics.SOP as SOP
18+import qualified GHC.Generics as GHC
19+import Data.Aeson
20+import Servant.Docs (ToSample, toSamples, samples)
21+import Data.Proxy
22+import Data.Text (Text)
23+import Data.Function (on)
24+import Data.Time.Clock
25+import Data.Time.Calendar
26+import qualified Data.Vector as V
27+import Data.User
28+
29+-- MARK: Documentation
30+
31+instance (ToSample u) => ToSample (NamedChannel u) where
32+ toSamples _ = samples $ NamedChannel <$> [8] <*> ["социология", "ФКН"] <*> [V.fromList ["thisIsHashTag", "thisIsAlsoHashTag"]] <*> [V.fromList (map snd $ toSamples Proxy)]
33+
34+
35+instance ToSample NamedChannelCreationRequest where
36+ toSamples _ = samples $ NamedChannelCreationRequest <$> ["социология", "ФКН"] <*> [V.fromList ["thisIsHashTag", "thisIsAlsoHashTag"]] <*> [V.fromList [2, 7, 8]]
37+
38+-- MARK: Implementation
39+
40+type NamedChannelId = Int64
41+
42+-- Note: Channel owner only exists in sql
43+data NamedChannel u = NamedChannel {
44+ namedChannelId :: NamedChannelId,
45+ namedChannelName :: Text,
46+ namedChannelTags :: V.Vector Text,
47+ namedChannelPeopleIds :: V.Vector u
48+} deriving GHC.Generic
49+
50+instance (ToJSON u) => ToJSON (NamedChannel u) where
51+ toJSON (NamedChannel cId cName cTags cPeople) = object [
52+ "id" .= cId,
53+ "name" .= cName,
54+ "tags" .= cTags,
55+ "people" .= cPeople ]
56+
57+instance (FromJSON u) => FromJSON (NamedChannel u) where
58+ parseJSON = withObject "named channel" $ \e ->
59+ NamedChannel <$> e .: "id" <*> e .: "name" <*> e .: "tags" <*> e .: "people"
60+
61+-- MARK: NamedChannelCreationRequest
62+
63+data NamedChannelCreationRequest = NamedChannelCreationRequest {
64+ namedChannelCreationRequestName :: Text,
65+ namedChannelCreationRequestTags :: V.Vector Text,
66+ namedChannelCreationRequestPeopleIds :: V.Vector UserId
67+} deriving GHC.Generic
68+
69+instance SOP.Generic NamedChannelCreationRequest
70+instance SOP.HasDatatypeInfo NamedChannelCreationRequest
71+
72+instance ToJSON NamedChannelCreationRequest where
73+ toJSON (NamedChannelCreationRequest cName cTags cPeople) = object [
74+ "name" .= cName,
75+ "tags" .= cTags,
76+ "people" .= cPeople ]
77+
78+instance FromJSON NamedChannelCreationRequest where
79+ parseJSON = withObject "named channel" $ \e ->
80+ NamedChannelCreationRequest <$> e .: "name" <*> e .: "tags" <*> e .: "people"
denis/src/Data/Post.hs+29−4
@@ -14,6 +14,7 @@ module Data.Post (
14 PostId,
14 PostId,
15 QuoteId,
15 QuoteId,
16 PostRowResponse(..),
16 PostRowResponse(..),
17+ PostCreation(..)
17) where
18) where
18
19
19import Data.Int (Int64)
20import Data.Int (Int64)
@@ -27,13 +28,17 @@ import Data.Text (Text)
27import Data.Function (on)
28import Data.Function (on)
28import Data.Time.Clock
29import Data.Time.Clock
29import Data.Time.Calendar
30import Data.Time.Calendar
31+import qualified Data.Vector as V
30
32
31-- MARK: Documentation
33-- MARK: Documentation
32
34
33instance ToSample Post where
35instance ToSample Post where
34− toSamples _ = samples $ [Post 8 17 time] <*> (map snd $ toSamples Proxy)
36+ toSamples _ = samples $ [Post 8 17 time $ V.fromList ["hse", "cs", "machineLearning"]] <*> (map snd $ toSamples Proxy)
35 where time = UTCTime (ModifiedJulianDay 1000) 8
37 where time = UTCTime (ModifiedJulianDay 1000) 8
36
38
39+instance ToSample PostCreation where
40+ toSamples _ = samples $ PostCreation <$> (map snd $ toSamples Proxy) <*> [(V.fromList ["hse", "cs", "machineLearning"])]
41+
37
42
38-- MARK: Actual type
43-- MARK: Actual type
39
44
@@ -44,16 +49,35 @@ data Post = Post {
44 postId :: Int64,
49 postId :: Int64,
45 postAuthorId :: Int64,
50 postAuthorId :: Int64,
46 updated :: UTCTime,
51 updated :: UTCTime,
52+ postTags :: V.Vector Text,
47 postBody :: [PostElement Post]
53 postBody :: [PostElement Post]
48}
54}
49
55
50instance ToJSON Post where
56instance ToJSON Post where
51− toJSON (Post pId aId tm pb) = object [
57+ toJSON (Post pId aId tm tags pb) = object [
52 "id" .= pId,
58 "id" .= pId,
53 "authorId" .= aId,
59 "authorId" .= aId,
54 "updated" .= tm,
60 "updated" .= tm,
61+ "tags" .= tags,
55 "body" .= pb ]
62 "body" .= pb ]
56
63
64+data PostCreation = PostCreation {
65+ postCreationBody :: [PostElement Post],
66+ postCreationTags :: V.Vector Text
67+} deriving GHC.Generic
68+
69+instance SOP.Generic PostCreation
70+instance SOP.HasDatatypeInfo PostCreation
71+
72+instance ToJSON PostCreation where
73+ toJSON (PostCreation body tags) = object [
74+ "tags" .= tags,
75+ "body" .= body ]
76+
77+instance FromJSON PostCreation where
78+ parseJSON = withObject "post creation" $ \e ->
79+ PostCreation <$> e .: "body" <*> e .: "tags"
80+
57
81
58-- MARK: Rows
82-- MARK: Rows
59
83
@@ -64,6 +88,7 @@ data PostRowResponse = PostRowResponse {
64 postRowId :: Int64,
88 postRowId :: Int64,
65 postRowAuthorId :: Int64,
89 postRowAuthorId :: Int64,
66 postRowUpdateTime :: UTCTime,
90 postRowUpdateTime :: UTCTime,
91+ postRowTags :: V.Vector Text,
67
92
68 -- ElementRow
93 -- ElementRow
69 rowElementOrd :: Int64,
94 rowElementOrd :: Int64,
@@ -78,10 +103,10 @@ instance SOP.Generic PostRowResponse
78instance SOP.HasDatatypeInfo PostRowResponse
103instance SOP.HasDatatypeInfo PostRowResponse
79
104
80unRow :: MkElementRow x -> PostRowResponse -> x
105unRow :: MkElementRow x -> PostRowResponse -> x
81−unRow f' (PostRowResponse _ _ _ _ a b c d e) = f' a b c d e
106+unRow f' (PostRowResponse _ _ _ _ _ a b c d e) = f' a b c d e
82
107
83rowsToPost :: [PostRowResponse] -> Maybe Post
108rowsToPost :: [PostRowResponse] -> Maybe Post
84rowsToPost [] = Nothing
109rowsToPost [] = Nothing
85rowsToPost (el:els) = if all (((==) `on` postRowId) el) els
110rowsToPost (el:els) = if all (((==) `on` postRowId) el) els
86− then Post (postRowId el) (postRowAuthorId el) (postRowUpdateTime el) <$> traverse (unRow rowsToElement) (el:els)
111+ then Post (postRowId el) (postRowAuthorId el) (postRowUpdateTime el) (postRowTags el) <$> traverse (unRow rowsToElement) (el:els)
87 else Nothing
112 else Nothing
denis/src/Data/Query.hs+133−7
@@ -20,7 +20,12 @@ module Data.Query (
20 getPostsForUser,
20 getPostsForUser,
21 Limit,
21 Limit,
22 publishPost,
22 publishPost,
23− PostResponse(..)
23+ PostResponse(..),
24+ getChannelPosts,
25+ updateChannel,
26+ createNewChannel,
27+ getAllChannels,
28+ getAnonymousChannelPosts
24) where
29) where
25
30
26import Squeal.PostgreSQL
31import Squeal.PostgreSQL
@@ -37,12 +42,20 @@ import Data.Word (Word64)
37import qualified Data.List as L
42import qualified Data.List as L
38import qualified Data.Map.Strict as M
43import qualified Data.Map.Strict as M
39import qualified Data.Set as Set
44import qualified Data.Set as Set
45+import qualified Generics.SOP as SOP
46+import qualified GHC.Generics as GHC
40import Data.Int (Int64)
47import Data.Int (Int64)
41import Data.ByteString.Char8 (pack)
48import Data.ByteString.Char8 (pack)
42import GHC.Generics (Generic)
49import GHC.Generics (Generic)
43import Data.Aeson
50import Data.Aeson
44import Servant.Docs
51import Servant.Docs
45import Data.Proxy
52import Data.Proxy
53+import Data.Vector (Vector, toList)
54+import Data.Text (Text)
55+import Data.Channel.NamedChannel
56+import Data.Channel.AnonymousChannel
57+import Data.Maybe (fromMaybe)
58+import Data.Monoid (mempty)
46
59
47-- MARK: Documentation
60-- MARK: Documentation
48
61
@@ -68,6 +81,7 @@ getPostQ oTe te = select (
68 #posts ! #postRowId :*
81 #posts ! #postRowId :*
69 #posts ! #postRowAuthorId :*
82 #posts ! #postRowAuthorId :*
70 #posts ! #postRowUpdateTime :*
83 #posts ! #postRowUpdateTime :*
84+ #posts ! #postRowTags :*
71 -- #rowElementId :*
85 -- #rowElementId :*
72 #postElements ! #rowElementOrd :*
86 #postElements ! #rowElementOrd :*
73 #postElements ! #rowElementMarkdown :*
87 #postElements ! #rowElementMarkdown :*
@@ -128,11 +142,12 @@ getLastNPostsForUserQ lim = getPostQ
128 (limit lim . orderBy [#posts ! #postRowUpdateTime & Desc])
142 (limit lim . orderBy [#posts ! #postRowUpdateTime & Desc])
129 (where_ $ #postRowAuthorId .== param @1)
143 (where_ $ #postRowAuthorId .== param @1)
130
144
131−createPostRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only PostId))
145+createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))
132createPostRowQ = insertRow #posts
146createPostRowQ = insertRow #posts
133 (Default `as` #postRowId :*
147 (Default `as` #postRowId :*
134 Set (param @1) `as` #postRowAuthorId :*
148 Set (param @1) `as` #postRowAuthorId :*
135− Set currentTimestamp `as` #postRowUpdateTime)
149+ Set currentTimestamp `as` #postRowUpdateTime :*
150+ Set (param @2) `as` #postRowTags)
136 OnConflictDoRaise
151 OnConflictDoRaise
137 (Returning $ #postRowId `as` #fromOnly)
152 (Returning $ #postRowId `as` #fromOnly)
138
153
@@ -146,6 +161,52 @@ createPostElementRowsQ = insertRow_ #postElements
146 Set (param @6) `as` #rowElementQuote :*
161 Set (param @6) `as` #rowElementQuote :*
147 Set (param @7) `as` #rowElementAttachment)
162 Set (param @7) `as` #rowElementAttachment)
148
163
164+getChannelForUserQ :: Query Schema (TuplePG (UserId, NamedChannelId)) (RowPG NamedChannelFull)
165+getChannelForUserQ = selectStar $
166+ from (table #channels) &
167+ where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
168+
169+getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
170+getAllChannelsForUserQ = selectStar $
171+ from (table #channels) &
172+ where_ (#namedChannelFullOwner .== param @1)
173+
174+createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))
175+createNamedChannelQ = insertRow #channels
176+ (
177+ Default `as` #namedChannelFullId :*
178+ Set (param @1) `as` #namedChannelFullOwner :*
179+ Set (param @2) `as` #namedChannelFullName :*
180+ Set (param @3) `as` #namedChannelFullTags :*
181+ Set (param @4) `as` #namedChannelFullPeopleIds
182+ )
183+ OnConflictDoRaise
184+ (Returning $ #namedChannelFullId `as` #fromOnly)
185+
186+updateNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelFull) '[]
187+updateNamedChannelQ = update_ #channels
188+ (
189+ Same `as` #namedChannelFullId :*
190+ Same `as` #namedChannelFullOwner :*
191+ Set (param @3) `as` #namedChannelFullName :*
192+ Set (param @4) `as` #namedChannelFullTags :*
193+ Set (param @5) `as` #namedChannelFullPeopleIds
194+ )
195+ (#namedChannelFullOwner .== param @2 .&& #namedChannelFullId .== param @2)
196+
197+
198+getChannelPostsQ :: Limit -> [UserId] -> Vector Text -> Query Schema '[] (RowPG PostRowResponse)
199+getChannelPostsQ lim uIds tags = selectStar $ from (subquery $ postsQ' `As` #bar) &
200+ orderBy [#postRowUpdateTime & Desc] & limit lim
201+ where
202+ unionWithUsers = case idsToColumn uIds of
203+ Just uIdsQ -> selectDotStar #posts' (from $ subquery (uIdsQ `As` #uIds) &
204+ innerJoin (subquery $ getPostQ id id `As` #posts')
205+ (#uIds ! #id .== #posts' ! #postRowAuthorId)) &
206+ union
207+ Nothing -> id
208+ postsQ' = unionWithUsers $ getPostQ id $ where_ $ jsonbLit tags .?| #postRowTags
209+
149
210
150-- MARK: FrontEnd Data Structures
211-- MARK: FrontEnd Data Structures
151
212
@@ -156,6 +217,44 @@ data PostResponse = PostResponse {
156
217
157instance ToJSON PostResponse
218instance ToJSON PostResponse
158
219
220+data NamedChannelCreation = NamedChannelCreation {
221+ namedChannelCreationOwner :: UserId,
222+ namedChannelCreationName :: Text,
223+ namedChannelCreationTags :: Vector Text,
224+ namedChannelCreationPeopleIds :: Vector UserId
225+} deriving GHC.Generic
226+
227+instance SOP.Generic NamedChannelCreation
228+instance SOP.HasDatatypeInfo NamedChannelCreation
229+
230+addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation
231+addUserToChannelCreate uId (NamedChannelCreationRequest cName cTags cPeople) = NamedChannelCreation uId cName cTags cPeople
232+
233+
234+data NamedChannelFull = NamedChannelFull {
235+ namedChannelFullId :: NamedChannelId,
236+ namedChannelFullOwner :: UserId,
237+ namedChannelFullName :: Text,
238+ namedChannelFullTags :: Vector Text,
239+ namedChannelFullPeopleIds :: Vector UserId
240+} deriving GHC.Generic
241+
242+instance SOP.Generic NamedChannelFull
243+instance SOP.HasDatatypeInfo NamedChannelFull
244+
245+addUserToChannelUpdate :: UserId -> NamedChannel UserId -> NamedChannelFull
246+addUserToChannelUpdate uId (NamedChannel cId cName cTags cPeople) = NamedChannelFull cId uId cName cTags cPeople
247+
248+removeUserFromChannel :: NamedChannelFull -> NamedChannel UserId
249+removeUserFromChannel (NamedChannelFull cId _ cName cTags cPeople) = NamedChannel cId cName cTags cPeople
250+
251+getChannelForUser :: UserId -> NamedChannelId -> StaticPQ NamedChannelFull
252+getChannelForUser uId cId = do
253+ channel <- runQueryParams getChannelForUserQ (uId, cId) >>= firstRow
254+ case (channel :: Maybe NamedChannelFull) of
255+ (Just c) -> return c
256+ Nothing -> lift $ S.throwError S.err404
257+
159
258
160-- MARK: FrontEnd functions
259-- MARK: FrontEnd functions
161
260
@@ -183,16 +282,43 @@ getUser uId = runQueryParams getUserQ (Only uId) >>= getRow 0
183getUsers :: [UserId] -> StaticPQ (Maybe [User])
282getUsers :: [UserId] -> StaticPQ (Maybe [User])
184getUsers ids = getUsersQ ids `liftMaybe` (fmap Just . (runQuery >=> getRows))
283getUsers ids = getUsersQ ids `liftMaybe` (fmap Just . (runQuery >=> getRows))
185
284
186−publishPost :: UserId -> [PostElement Post] -> StaticPQ PostId
285+publishPost :: UserId -> PostCreation -> StaticPQ PostId
187−publishPost uId els = transactionally_ $ do
286+publishPost uId pc = transactionally_ $ do
188− pId' <- manipulateParams createPostRowQ (Only uId) >>= firstRow
287+ pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
189 case pId' of
288 case pId' of
190 (Just (Only pId)) -> do
289 (Just (Only pId)) -> do
191− traversePrepared_ createPostElementRowsQ $ elementsToRows pId els
290+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (postCreationBody pc)
192 return pId
291 return pId
193 _ -> lift $ S.throwError S.err404
292 _ -> lift $ S.throwError S.err404
194
293
294+createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
295+createNewChannel uId req = transactionally_ $ do
296+ cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId req) >>= firstRow
297+ return $ fmap fromOnly cId
298+
299+updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
300+updateChannel uId req = transactionally_ $ do
301+ _ <- getChannelForUser uId $ namedChannelId req
302+ _ <- manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId req
303+ return ()
304+
305+getChannelPosts :: UserId -> Limit -> NamedChannelId -> StaticPQ PostResponse
306+getChannelPosts uId lim cId = do
307+ channel <- getChannelForUser uId cId
308+ postRows <- runQuery (getChannelPostsQ lim (toList $ namedChannelFullPeopleIds channel) (namedChannelFullTags channel))
309+ >>= getRows
310+ fmap (fromMaybe $ PostResponse mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoPostResponse
311+
312+getAnonymousChannelPosts :: Limit -> AnonymousChannel -> StaticPQ PostResponse
313+getAnonymousChannelPosts lim (AnonymousChannel tags people) = do
314+ postRows <- runQuery (getChannelPostsQ lim people tags) >>= getRows
315+ fmap (fromMaybe $ PostResponse mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoPostResponse
316+
317+getAllChannels :: UserId -> StaticPQ [NamedChannel UserId]
318+getAllChannels uId = fmap (map removeUserFromChannel) $
319+ runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
195
320
321+
196-- MARK: Utils
322-- MARK: Utils
197
323
198foldMaybe :: [Maybe a] -> Maybe [a]
324foldMaybe :: [Maybe a] -> Maybe [a]
denis/src/Data/Schema.hs+28−4
@@ -32,7 +32,8 @@ type Schema =
32 '[
32 '[
33 "postRowId" ::: 'Def :=> 'NotNull 'PGint8,
33 "postRowId" ::: 'Def :=> 'NotNull 'PGint8,
34 "postRowAuthorId" ::: 'NoDef :=> 'NotNull 'PGint8,
34 "postRowAuthorId" ::: 'NoDef :=> 'NotNull 'PGint8,
35− "postRowUpdateTime" ::: 'NoDef :=> 'NotNull 'PGtimestamptz
35+ "postRowUpdateTime" ::: 'NoDef :=> 'NotNull 'PGtimestamptz,
36+ "postRowTags" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGtext))
36 ]),
37 ]),
37 "quotes" ::: 'Table (
38 "quotes" ::: 'Table (
38 '[
39 '[
@@ -73,7 +74,20 @@ type Schema =
73 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
74 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
74 "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
75 "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
75 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
76 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
76− -- ]),
77+ ]),
78+ "channels" ::: 'Table (
79+ '[
80+ "pk_channels" ::: 'PrimaryKey '["namedChannelFullId"],
81+ "fk_channels_users_id" ::: 'ForeignKey '["namedChannelFullOwner"] "users" '["userId"]
82+ ] :=>
83+ '[
84+ "namedChannelFullId" ::: 'Def :=> 'NotNull 'PGint8,
85+ "namedChannelFullOwner" ::: 'NoDef :=> 'NotNull 'PGint8,
86+ "namedChannelFullName" ::: 'NoDef :=> 'NotNull 'PGtext,
87+ "namedChannelFullTags" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGtext)),
88+ "namedChannelFullPeopleIds" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGint8))
89+ ]
90+ )
77 -- "postsView" ::: 'View (RowPG PostRowResponse)
91 -- "postsView" ::: 'View (RowPG PostRowResponse)
78 -- ('[
92 -- ('[
79 -- "postRowId" ::: 'NotNull 'PGint8,
93 -- "postRowId" ::: 'NotNull 'PGint8,
@@ -85,7 +99,7 @@ type Schema =
85 -- "rowElementImage" ::: 'Null 'PGtext,
99 -- "rowElementImage" ::: 'Null 'PGtext,
86 -- "rowElementQuote" ::: 'Null 'PGint8,
100 -- "rowElementQuote" ::: 'Null 'PGint8,
87 -- "rowElementAttachment" ::: 'Null 'PGtext
101 -- "rowElementAttachment" ::: 'Null 'PGtext
88− ])
102+ -- ])
89
103
90 ]
104 ]
91
105
@@ -101,7 +115,8 @@ createTables = createTable #users (
101 ) >>> createTable #posts (
115 ) >>> createTable #posts (
102 serial8 `as` #postRowId :*
116 serial8 `as` #postRowId :*
103 notNullable int8 `as` #postRowAuthorId :*
117 notNullable int8 `as` #postRowAuthorId :*
104− notNullable timestampWithTimeZone `as` #postRowUpdateTime
118+ notNullable timestampWithTimeZone `as` #postRowUpdateTime :*
119+ notNullable (vararray text) `as` #postRowTags
105 ) (
120 ) (
106 primaryKey #postRowId `as` #pk_posts :*
121 primaryKey #postRowId `as` #pk_posts :*
107 foreignKey #postRowAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_author_id
122 foreignKey #postRowAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_author_id
@@ -133,6 +148,15 @@ createTables = createTable #users (
133 ) (
148 ) (
134 foreignKey #rowElementId #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quotes_quote_self_id :*
149 foreignKey #rowElementId #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quotes_quote_self_id :*
135 foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_quote_id
150 foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_quote_id
151+ ) >>> createTable #channels (
152+ serial8 `as` #namedChannelFullId :*
153+ notNullable int8 `as` #namedChannelFullOwner :*
154+ notNullable text `as` #namedChannelFullName :*
155+ notNullable (vararray text) `as` #namedChannelFullTags :*
156+ notNullable (vararray int8) `as` #namedChannelFullPeopleIds
157+ ) (
158+ primaryKey #namedChannelFullId `as` #pk_channels :*
159+ foreignKey #namedChannelFullOwner #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_channels_users_id
136 -- ) >>> createView #postsView (select (
160 -- ) >>> createView #postsView (select (
137 -- #posts ! #postRowId :*
161 -- #posts ! #postRowId :*
138 -- #posts ! #postRowAuthorId :*
162 -- #posts ! #postRowAuthorId :*
denis/src/Server/API.hs+5−2
@@ -24,6 +24,7 @@ import Server.App
24import Server.API.Posts
24import Server.API.Posts
25import Server.Logger
25import Server.Logger
26import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))
26import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))
27+import Server.API.Channels
27import Control.Lens
28import Control.Lens
28
29
29
30
@@ -44,7 +45,8 @@ type API =
44 Authentication :> (
45 Authentication :> (
45 "authentication" :> "me" :> Post '[JSON] UserId :<|>
46 "authentication" :> "me" :> Post '[JSON] UserId :<|>
46 "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>
47 "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>
47− "posts" :> PostApi
48+ "posts" :> PostApi :<|>
49+ "channels" :> ChannelsApi
48 )
50 )
49
51
50serverProxy :: Proxy API
52serverProxy :: Proxy API
@@ -56,5 +58,6 @@ mkServerAPI l =
56 authenticationAPI :<|> (\uId ->
58 authenticationAPI :<|> (\uId ->
57 return uId :<|>
59 return uId :<|>
58 maybeNotFound . runQnotFound . getUsers :<|>
60 maybeNotFound . runQnotFound . getUsers :<|>
59− postApi uId
61+ postApi uId :<|>
62+ channelsApi uId
60 )
63 )
denis/src/Server/API/Channels.hsnew file+57
@@ -0,0 +1,57 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators #-}
8+
9+module Server.API.Channels (
10+ ChannelsApi,
11+ channelsApi
12+) where
13+
14+import Servant.API
15+import qualified Data.Post as P
16+import Data.Aeson
17+import Server.App
18+import Servant.Server
19+import Data.Query
20+import Data.User
21+import Data.Connection
22+import Data.Word (Word64)
23+import Servant.Docs (ToSample, toSamples, samples)
24+import Server.LimitingRequest
25+import Data.Channel.NamedChannel
26+import Data.Channel.AnonymousChannel
27+
28+-- MARK: Implementation
29+
30+type NamedChannelRequest = LimitingRequest NamedChannelId
31+
32+type ChannelsApi = Post '[JSON] [NamedChannel UserId] :<|>
33+ "get" :> ReqBody '[JSON] NamedChannelRequest :> Post '[JSON] PostResponse :<|>
34+ "getAnonymous" :> ReqBody '[JSON] (LimitingRequest AnonymousChannel) :> Post '[JSON] PostResponse :<|>
35+ "create" :> ReqBody '[JSON] NamedChannelCreationRequest :> Post '[JSON] NamedChannelId :<|>
36+ "update" :> ReqBody '[JSON] (NamedChannel UserId) :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent
37+
38+channelsApi :: UserId -> ServerT ChannelsApi App
39+channelsApi uId = getChannelsApi uId :<|> getChannel uId :<|> getAnonymousChannelsApi :<|> createChannelApi uId :<|> updateChannelApi uId
40+
41+
42+getChannelsApi :: UserId -> App [NamedChannel UserId]
43+getChannelsApi uId = runQnotFound $ getAllChannels uId
44+
45+getAnonymousChannelsApi :: LimitingRequest AnonymousChannel -> App PostResponse
46+getAnonymousChannelsApi (LimitingRequest req lim) = runQnotFound $ getAnonymousChannelPosts lim req
47+
48+getChannel :: UserId -> NamedChannelRequest -> App PostResponse
49+getChannel uId (LimitingRequest cId lim) = runQnotFound $ getChannelPosts uId lim cId
50+
51+createChannelApi :: UserId -> NamedChannelCreationRequest -> App NamedChannelId
52+createChannelApi uId req = maybeNotFound . runQnotFound $ createNewChannel uId req
53+
54+updateChannelApi :: UserId -> NamedChannel UserId -> App NoContent
55+updateChannelApi uId req = do
56+ runQnotFound $ updateChannel uId req
57+ return NoContent
denis/src/Server/API/Posts.hs+6−21
@@ -9,42 +9,27 @@
9module Server.API.Posts (
9module Server.API.Posts (
10 PostApi,
10 PostApi,
11 postApi,
11 postApi,
12− UserPostsRequest(..)
12+ UserPostsRequest
13) where
13) where
14
14
15import Servant.API
15import Servant.API
16import qualified Data.Post as P
16import qualified Data.Post as P
17−import Data.Aeson
18import Server.App
17import Server.App
19import Servant.Server
18import Servant.Server
20import Data.Query
19import Data.Query
21import Data.User
20import Data.User
22import Data.Connection
21import Data.Connection
23import Data.Word (Word64)
22import Data.Word (Word64)
24−import Servant.Docs (ToSample, toSamples, samples)
23+import Server.LimitingRequest
25−
26−-- MARK: Documentation
27
24
28−instance ToSample UserPostsRequest where
29− toSamples _ = samples [UserPostsRequest 8 10, UserPostsRequest 42 20]
30−
31-- MARK: Implementation
25-- MARK: Implementation
32
26
33−data UserPostsRequest = UserPostsRequest {
27+type UserPostsRequest = LimitingRequest UserId
34− userPostRequestId :: UserId,
35− userPostRequestLimit :: Word64
36−}
37−
38−instance ToJSON UserPostsRequest where
39− toJSON (UserPostsRequest uId lim) = object ["userId" .= uId, "limit" .= lim]
40−instance FromJSON UserPostsRequest where
41− parseJSON = withObject "User posts request" $ \e ->
42− UserPostsRequest <$> e .: "userId" <*> e.: "limit"
43
28
44type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] PostResponse :<|>
29type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] PostResponse :<|>
45 "last" :> ReqBody '[JSON] Word64 :> Post '[JSON] PostResponse :<|>
30 "last" :> ReqBody '[JSON] Word64 :> Post '[JSON] PostResponse :<|>
46 "forUser" :> ReqBody '[JSON] UserPostsRequest :> Post '[JSON] PostResponse :<|>
31 "forUser" :> ReqBody '[JSON] UserPostsRequest :> Post '[JSON] PostResponse :<|>
47− "publish" :> ReqBody '[JSON] [P.PostElement P.Post] :> Post '[JSON] P.PostId
32+ "publish" :> ReqBody '[JSON] P.PostCreation :> Post '[JSON] P.PostId
48
33
49postApi :: UserId -> ServerT PostApi App
34postApi :: UserId -> ServerT PostApi App
50postApi uId = getPostsApi :<|> lastPosts :<|> getPostsForUserApi :<|> publishPostApi uId
35postApi uId = getPostsApi :<|> lastPosts :<|> getPostsForUserApi :<|> publishPostApi uId
@@ -56,7 +41,7 @@ lastPosts :: Word64 -> App PostResponse
56lastPosts = maybeNotFound . runQnotFound . getLastPosts
41lastPosts = maybeNotFound . runQnotFound . getLastPosts
57
42
58getPostsForUserApi :: UserPostsRequest -> App PostResponse
43getPostsForUserApi :: UserPostsRequest -> App PostResponse
59−getPostsForUserApi (UserPostsRequest uId lim) = maybeNotFound . runQnotFound $ getPostsForUser lim uId
44+getPostsForUserApi (LimitingRequest uId lim) = maybeNotFound . runQnotFound $ getPostsForUser lim uId
60
45
61−publishPostApi :: UserId -> [P.PostElement P.Post] -> App P.PostId
46+publishPostApi :: UserId -> P.PostCreation -> App P.PostId
62publishPostApi uId = runQerror . publishPost uId
47publishPostApi uId = runQerror . publishPost uId
denis/src/Server/LimitingRequest.hsnew file+29
@@ -0,0 +1,29 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Server.LimitingRequest (
4+ LimitingRequest(..)
5+) where
6+
7+import Data.Word (Word64)
8+import Servant.Docs (ToSample, toSamples, samples)
9+import Data.Aeson
10+import Data.Proxy
11+
12+instance (ToSample r) => ToSample (LimitingRequest r) where
13+ toSamples _ = samples $ LimitingRequest <$> (map snd $ toSamples Proxy) <*> [1, 11, 17]
14+
15+
16+data LimitingRequest r = LimitingRequest {
17+ requestRequest :: r,
18+ requestLimit :: Word64
19+}
20+
21+instance (ToJSON r) => ToJSON (LimitingRequest r) where
22+ toJSON (LimitingRequest r l) = object [
23+ "request" .= r,
24+ "limit" .= l ]
25+
26+instance (FromJSON r) => FromJSON (LimitingRequest r) where
27+ parseJSON = withObject "limiting request" $ \e ->
28+ LimitingRequest <$> e .: "request" <*> e .: "limit"
29+