9451b5f · denis · git.iko.soy

git.iko.soy/denis

Resolved #5.

Resolved #23.

commit9451b5f463ad4ac577dd54aa098f453c94b416fd authoriko <ilyakooo0@gmail.com> dateTue 12 Mar 2019, 16:03 (8 years ago) parent0fd03c1

11 files changed+429−41

compare with master

unifiedsplit

denis/docs/Docs.hs+7−3 denis/package.yaml+1 denis/src/Data/Channel/AnonymousChannel.hs+54 denis/src/Data/Channel/NamedChannel.hs+80 denis/src/Data/Post.hs+29−4 denis/src/Data/Query.hs+133−7 denis/src/Data/Schema.hs+28−4 denis/src/Server/API.hs+5−2 denis/src/Server/API/Channels.hs+57 denis/src/Server/API/Posts.hs+6−21 denis/src/Server/LimitingRequest.hs+29

denis/docs/Docs.hs+7−3

@@ -19,15 +19,19 @@ import Data.Word (Word64)

1919import Server.API.Posts

2020import Server.Logger

2121import Server.Auth

22+import Server.API.Channels

23+import Data.Aeson

2224

2325docsWriter :: HasDocs api => String -> Proxy api -> IO ()

2426docsWriter file = writeFile ("docs/" ++ file ++ ".md") . normalizer . markdown . docs

2527

2628main = do

27− docsWriter "posts" (Proxy :: Proxy ("posts" :> PostApi))

28− docsWriter "all" serverProxy

29− docsWriter "authentication" (Proxy :: Proxy ("authentication" :> AuthenticationHandler :<|>

29+ docsWriter "posts" $ pretty (Proxy :: Proxy ("posts" :> PostApi))

30+ docsWriter "all" $ pretty serverProxy

31+ docsWriter "authentication" $ pretty (Proxy :: Proxy ("authentication" :> AuthenticationHandler :<|>

3032 Authentication :> "authentication" :> "me" :> Post '[JSON] UserId ))

33+ docsWriter "channels" $ pretty (Proxy :: Proxy ("channels" :> ChannelsApi))

34+

3135

3236instance ToSample Char where

3337 toSamples _ = singleSample 'c'

denis/package.yaml+1

@@ -48,6 +48,7 @@ dependencies:

4848- wai-extra

4949- data-default-class

5050- fast-logger

51+- vector

5152

5253- lens

5354

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 #-}

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 #-}

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 (

1414 PostId,

1515 QuoteId,

1616 PostRowResponse(..),

17+ PostCreation(..)

1718) where

1819

1920import Data.Int (Int64)

@@ -27,13 +28,17 @@ import Data.Text (Text)

2728import Data.Function (on)

2829import Data.Time.Clock

2930import Data.Time.Calendar

31+import qualified Data.Vector as V

3032

3133-- MARK: Documentation

3234

3335instance 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)

3537 where time = UTCTime (ModifiedJulianDay 1000) 8

3638

39+instance ToSample PostCreation where

40+ toSamples _ = samples $ PostCreation <$> (map snd $ toSamples Proxy) <*> [(V.fromList ["hse", "cs", "machineLearning"])]

41+

3742

3843-- MARK: Actual type

3944

@@ -44,16 +49,35 @@ data Post = Post {

4449 postId :: Int64,

4550 postAuthorId :: Int64,

4651 updated :: UTCTime,

52+ postTags :: V.Vector Text,

4753 postBody :: [PostElement Post]

4854}

4955

5056instance ToJSON Post where

51− toJSON (Post pId aId tm pb) = object [

57+ toJSON (Post pId aId tm tags pb) = object [

5258 "id" .= pId,

5359 "authorId" .= aId,

5460 "updated" .= tm,

61+ "tags" .= tags,

5562 "body" .= pb ]

5663

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+

5781

5882-- MARK: Rows

5983

@@ -64,6 +88,7 @@ data PostRowResponse = PostRowResponse {

6488 postRowId :: Int64,

6589 postRowAuthorId :: Int64,

6690 postRowUpdateTime :: UTCTime,

91+ postRowTags :: V.Vector Text,

6792

6893 -- ElementRow

6994 rowElementOrd :: Int64,

@@ -78,10 +103,10 @@ instance SOP.Generic PostRowResponse

78103instance SOP.HasDatatypeInfo PostRowResponse

79104

80105unRow :: 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

82107

83108rowsToPost :: [PostRowResponse] -> Maybe Post

84109rowsToPost [] = Nothing

85110rowsToPost (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)

87112 else Nothing

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

@@ -20,7 +20,12 @@ module Data.Query (

2020 getPostsForUser,

2121 Limit,

2222 publishPost,

23− PostResponse(..)

23+ PostResponse(..),

24+ getChannelPosts,

25+ updateChannel,

26+ createNewChannel,

27+ getAllChannels,

28+ getAnonymousChannelPosts

2429) where

2530

2631import Squeal.PostgreSQL

@@ -37,12 +42,20 @@ import Data.Word (Word64)

3742import qualified Data.List as L

3843import qualified Data.Map.Strict as M

3944import qualified Data.Set as Set

45+import qualified Generics.SOP as SOP

46+import qualified GHC.Generics as GHC

4047import Data.Int (Int64)

4148import Data.ByteString.Char8 (pack)

4249import GHC.Generics (Generic)

4350import Data.Aeson

4451import Servant.Docs

4552import 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)

4659

4760-- MARK: Documentation

4861

@@ -68,6 +81,7 @@ getPostQ oTe te = select (

6881 #posts ! #postRowId :*

6982 #posts ! #postRowAuthorId :*

7083 #posts ! #postRowUpdateTime :*

84+ #posts ! #postRowTags :*

7185 -- #rowElementId :*

7286 #postElements ! #rowElementOrd :*

7387 #postElements ! #rowElementMarkdown :*

@@ -128,11 +142,12 @@ getLastNPostsForUserQ lim = getPostQ

128142 (limit lim . orderBy [#posts ! #postRowUpdateTime & Desc])

129143 (where_ $ #postRowAuthorId .== param @1)

130144

131−createPostRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only PostId))

145+createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))

132146createPostRowQ = insertRow #posts

133147 (Default `as` #postRowId :*

134148 Set (param @1) `as` #postRowAuthorId :*

135− Set currentTimestamp `as` #postRowUpdateTime)

149+ Set currentTimestamp `as` #postRowUpdateTime :*

150+ Set (param @2) `as` #postRowTags)

136151 OnConflictDoRaise

137152 (Returning $ #postRowId `as` #fromOnly)

138153

@@ -146,6 +161,52 @@ createPostElementRowsQ = insertRow_ #postElements

146161 Set (param @6) `as` #rowElementQuote :*

147162 Set (param @7) `as` #rowElementAttachment)

148163

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+

149210

150211-- MARK: FrontEnd Data Structures

151212

@@ -156,6 +217,44 @@ data PostResponse = PostResponse {

156217

157218instance ToJSON PostResponse

158219

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+

159258

160259-- MARK: FrontEnd functions

161260

@@ -183,16 +282,43 @@ getUser uId = runQueryParams getUserQ (Only uId) >>= getRow 0

183282getUsers :: [UserId] -> StaticPQ (Maybe [User])

184283getUsers ids = getUsersQ ids `liftMaybe` (fmap Just . (runQuery >=> getRows))

185284

186−publishPost :: UserId -> [PostElement Post] -> StaticPQ PostId

187−publishPost uId els = transactionally_ $ do

188− pId' <- manipulateParams createPostRowQ (Only uId) >>= firstRow

285+publishPost :: UserId -> PostCreation -> StaticPQ PostId

286+publishPost uId pc = transactionally_ $ do

287+ pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow

189288 case pId' of

190289 (Just (Only pId)) -> do

191− traversePrepared_ createPostElementRowsQ $ elementsToRows pId els

290+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (postCreationBody pc)

192291 return pId

193292 _ -> lift $ S.throwError S.err404

194293

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

195320

321+

196322-- MARK: Utils

197323

198324foldMaybe :: [Maybe a] -> Maybe [a]

denis/src/Data/Schema.hs+28−4

@@ -32,7 +32,8 @@ type Schema =

3232 '[

3333 "postRowId" ::: 'Def :=> 'NotNull 'PGint8,

3434 "postRowAuthorId" ::: 'NoDef :=> 'NotNull 'PGint8,

35− "postRowUpdateTime" ::: 'NoDef :=> 'NotNull 'PGtimestamptz

35+ "postRowUpdateTime" ::: 'NoDef :=> 'NotNull 'PGtimestamptz,

36+ "postRowTags" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGtext))

3637 ]),

3738 "quotes" ::: 'Table (

3839 '[

@@ -73,7 +74,20 @@ type Schema =

7374 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,

7475 "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,

7576 "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+ )

7791 -- "postsView" ::: 'View (RowPG PostRowResponse)

7892 -- ('[

7993 -- "postRowId" ::: 'NotNull 'PGint8,

@@ -85,7 +99,7 @@ type Schema =

8599 -- "rowElementImage" ::: 'Null 'PGtext,

86100 -- "rowElementQuote" ::: 'Null 'PGint8,

87101 -- "rowElementAttachment" ::: 'Null 'PGtext

88− ])

102+ -- ])

89103

90104 ]

91105

@@ -101,7 +115,8 @@ createTables = createTable #users (

101115 ) >>> createTable #posts (

102116 serial8 `as` #postRowId :*

103117 notNullable int8 `as` #postRowAuthorId :*

104− notNullable timestampWithTimeZone `as` #postRowUpdateTime

118+ notNullable timestampWithTimeZone `as` #postRowUpdateTime :*

119+ notNullable (vararray text) `as` #postRowTags

105120 ) (

106121 primaryKey #postRowId `as` #pk_posts :*

107122 foreignKey #postRowAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_author_id

@@ -133,6 +148,15 @@ createTables = createTable #users (

133148 ) (

134149 foreignKey #rowElementId #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quotes_quote_self_id :*

135150 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

136160 -- ) >>> createView #postsView (select (

137161 -- #posts ! #postRowId :*

138162 -- #posts ! #postRowAuthorId :*

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

@@ -24,6 +24,7 @@ import Server.App

2424import Server.API.Posts

2525import Server.Logger

2626import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))

27+import Server.API.Channels

2728import Control.Lens

2829

2930

@@ -44,7 +45,8 @@ type API =

4445 Authentication :> (

4546 "authentication" :> "me" :> Post '[JSON] UserId :<|>

4647 "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>

47− "posts" :> PostApi

48+ "posts" :> PostApi :<|>

49+ "channels" :> ChannelsApi

4850 )

4951

5052serverProxy :: Proxy API

@@ -56,5 +58,6 @@ mkServerAPI l =

5658 authenticationAPI :<|> (\uId ->

5759 return uId :<|>

5860 maybeNotFound . runQnotFound . getUsers :<|>

59− postApi uId

61+ postApi uId :<|>

62+ channelsApi uId

6063 )

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 #-}

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 @@

99module Server.API.Posts (

1010 PostApi,

1111 postApi,

12− UserPostsRequest(..)

12+ UserPostsRequest

1313) where

1414

1515import Servant.API

1616import qualified Data.Post as P

17−import Data.Aeson

1817import Server.App

1918import Servant.Server

2019import Data.Query

2120import Data.User

2221import Data.Connection

2322import Data.Word (Word64)

24−import Servant.Docs (ToSample, toSamples, samples)

25−

26−-- MARK: Documentation

23+import Server.LimitingRequest

2724

28−instance ToSample UserPostsRequest where

29− toSamples _ = samples [UserPostsRequest 8 10, UserPostsRequest 42 20]

30−

3125-- MARK: Implementation

3226

33−data UserPostsRequest = UserPostsRequest {

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"

27+type UserPostsRequest = LimitingRequest UserId

4328

4429type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] PostResponse :<|>

4530 "last" :> ReqBody '[JSON] Word64 :> Post '[JSON] PostResponse :<|>

4631 "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

4833

4934postApi :: UserId -> ServerT PostApi App

5035postApi uId = getPostsApi :<|> lastPosts :<|> getPostsForUserApi :<|> publishPostApi uId

@@ -56,7 +41,7 @@ lastPosts :: Word64 -> App PostResponse

5641lastPosts = maybeNotFound . runQnotFound . getLastPosts

5742

5843getPostsForUserApi :: UserPostsRequest -> App PostResponse

59−getPostsForUserApi (UserPostsRequest uId lim) = maybeNotFound . runQnotFound $ getPostsForUser lim uId

44+getPostsForUserApi (LimitingRequest uId lim) = maybeNotFound . runQnotFound $ getPostsForUser lim uId

6045

61−publishPostApi :: UserId -> [P.PostElement P.Post] -> App P.PostId

46+publishPostApi :: UserId -> P.PostCreation -> App P.PostId

6247publishPostApi uId = runQerror . publishPost uId

denis/src/Server/LimitingRequest.hsnew file+29

@@ -0,0 +1,29 @@

1+{-# LANGUAGE OverloadedStrings #-}

3+module Server.LimitingRequest (

4+ LimitingRequest(..)

5+) where

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+