git.iko.soy/denis
on master help sign in
Resolved #1.
commit77d5dac0baa3b7896296eb6b447dca2334591966 authoriko <ilyakooo0@gmail.com> dateMon 4 Mar 2019, 00:30 (8 years ago) parent4f0da78
10 files changed+248−380
compare with master
unifiedsplit
denis/docs/Docs.hs−1 denis/src/Data/Connection.hs+5−1 denis/src/Data/Post.hs+41−47 denis/src/Data/PostElement.hs+65−55 denis/src/Data/Query.hs+93−144 denis/src/Data/Schema.hs+32−43 denis/src/Server/API.hs+2−5 denis/src/Server/API/Draft.hs−78 denis/src/Server/API/Posts.hs+8−4 stack.yaml+2−2
denis/docs/Docs.hs−1
@@ -19,7 +19,6 @@ import Data.User
1919import Data.Int (Int64)
2020import Data.Word (Word64)
2121import Server.API.Posts
22−import Server.API.Draft
2322import Server.Logger
2423
2524main = writeFile "docs.md" . markdown . docs . pretty $ serverProxy
denis/src/Data/Connection.hs+5−1
@@ -11,7 +11,8 @@ module Data.Connection (
1111 StaticPQ,
1212 runQ,
1313 runQ',
14− runQnotFound
14+ runQnotFound,
15+ runQerror
1516) where
1617
1718import Squeal.PostgreSQL
@@ -33,3 +34,6 @@ runQ' conn err req = handleSqueal (const $ throwError err) $ runPoolPQ req conn
3334
3435runQnotFound :: StaticPQ a -> App a
3536runQnotFound = runQ err404
37+
38+runQerror :: StaticPQ a -> App a
39+runQerror = runQ err500
denis/src/Data/Post.hs+41−47
@@ -5,66 +5,52 @@
55 OverloadedStrings ,
66 TypeApplications ,
77 TypeOperators,
8− OverloadedStrings,
9− KindSignatures #-}
8+ OverloadedStrings #-}
109
1110module Data.Post (
12− Post,
11+ Post(..),
1312 PostElement,
14− PostQuote(..),
15− PostRow,
16− PostQuoteRow,
17− ElementRow,
18− postToRow,
19− postToElementRows,
13+ -- PostQuote(..),
14+ -- PostRow,
15+ -- PostQuoteRow,
16+ -- ElementRow,
17+ postToRows,
18+ -- postToElementRows,
2019 rowsToPost,
2120 PostId,
2221 QuoteId,
23− Draft,
24− DraftId,
25− mkDraft,
26− fromDraft,
27− PostData(..)
22+ PostRowResponse(..),
2823) where
2924
3025import Data.Int (Int64)
3126import qualified Generics.SOP as SOP
3227import qualified GHC.Generics as GHC
3328import Data.Aeson
34−import qualified Data.Map.Lazy as M
3529import Servant.Docs (ToSample, toSamples, samples)
3630import Data.Proxy
37−
3831import Data.PostElement
32+import Data.Text (Text)
33+import Data.Function (on)
3934
4035-- MARK: Documentation
4136
42−instance ToSample (PostData a) where
43− toSamples _ = samples $ [PostData 8 17] <*> (map snd $ toSamples Proxy)
37+instance ToSample Post where
38+ toSamples _ = samples $ [Post 8 17] <*> (map snd $ toSamples Proxy)
4439
4540
4641-- MARK: Actual type
4742
4843type PostId = Int64
4944type QuoteId = Int64
50−type DraftId = Int64
51−
52−data PostType = Draft | NonDraft
5345
54−data PostData (p :: PostType) = PostData {
46+data Post = Post {
5547 postId :: Int64,
5648 postAuthorId :: Int64,
57− postBody :: [PostElement (PostData p)]
49+ postBody :: [PostElement Post]
5850}
5951
60−type Post = (PostData 'NonDraft)
61−type Draft = (PostData 'Draft)
62−
63−mkDraft :: DraftId -> Int64 -> [PostElement Draft] -> Draft
64−mkDraft = PostData
65−
66−instance ToJSON (PostData p) where
67− toJSON (PostData pId aId pb) = object [
52+instance ToJSON Post where
53+ toJSON (Post pId aId pb) = object [
6854 "id" .= pId,
6955 "authorId" .= aId,
7056 "body" .= pb ]
@@ -72,25 +58,33 @@ instance ToJSON (PostData p) where
7258
7359-- MARK: Rows
7460
75−data PostRow = PostRow {
61+-- Need to manually maintain. Future: https://github.com/morphismtech/squeal/issues/96
62+
63+data PostRowResponse = PostRowResponse {
64+ -- PostRow
7665 postRowId :: Int64,
77− postRowAuthorId :: Int64
66+ postRowAuthorId :: Int64,
67+
68+ -- ElementRow
69+ rowElementOrd :: Int64,
70+ rowElementMarkdown :: Maybe Text,
71+ rowElementLatex :: Maybe Text,
72+ rowElementImage :: Maybe Text,
73+ rowElementQuote :: Maybe Int64,
74+ rowElementAttachment :: Maybe Text
7875} deriving (GHC.Generic)
7976
80−instance SOP.Generic PostRow
81−instance SOP.HasDatatypeInfo PostRow
82−
83−postToRow :: Post -> PostRow
84−postToRow (PostData pId aId _) = PostRow pId aId
77+instance SOP.Generic PostRowResponse
78+instance SOP.HasDatatypeInfo PostRowResponse
8579
86−postToElementRows :: PostData p -> [ElementRow (PostData p)]
87−postToElementRows (PostData pId _ pb) = elementsToRows pId pb
80+unRow :: MkElementRow x -> PostRowResponse -> x
81+unRow f' (PostRowResponse _ _ _ a b c d e) = f' a b c d e
8882
89−rowsToPost :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostRow -> [ElementRow (PostData p)] -> Maybe (PostData p)
90−rowsToPost erqs pqrs (PostRow pId aId) elementRows = PostData pId aId <$> rowsToElements erqs pqrs elementRows
83+postToRows :: Post -> [PostRowResponse]
84+postToRows (Post pId uId els) = map (\(el, f) -> elemenToRow f el) . zip els . map (PostRowResponse pId uId) $ [0..]
9185
92−fromDraft :: PostId -> ElementRow Draft -> ElementRow Post
93−fromDraft pId (ElementRow _ b c d e f g) = ElementRow pId b c d e f g
94−
95−-- tupleFirst :: (a -> b) -> a -> (b, a)
96−-- tupleFirst f a = (f a, a)
86+rowsToPost :: [PostRowResponse] -> Maybe Post
87+rowsToPost [] = Nothing
88+rowsToPost (el:els) = if all (((==) `on` postRowId) el) els
89+ then Post (postRowId el) (postRowAuthorId el) <$> traverse (unRow rowsToElement) (el:els)
90+ else Nothing
denis/src/Data/PostElement.hs+65−55
@@ -10,11 +10,11 @@
1010
1111module Data.PostElement (
1212 PostElement,
13− ElementRow(..),
14− elementsToRows,
15− PostQuoteRow(..),
16− PostQuote(..),
17− rowsToElements
13+ elemenToRow,
14+ rowsToElement,
15+ MkElementRow,
16+ PostElementRow(..),
17+ elementsToRows
1818) where
1919
2020import Data.Int (Int64)
@@ -22,9 +22,6 @@ import qualified Generics.SOP as SOP
2222import qualified GHC.Generics as GHC
2323import Data.Text (Text)
2424import Data.Aeson
25−import qualified Data.Map.Lazy as M
26−import Data.List (sortBy)
27−import Data.Function (on)
2825import Control.Applicative ((<|>))
2926import Servant.Docs (ToSample, toSamples, samples)
3027
@@ -46,18 +43,18 @@ data PostElement a = Markdown Text
4643 | Attachment Text
4744
4845
49−data ElementRow a = ElementRow {
50− rowElementId :: Int64, -- the source id
51− rowElementOrd :: Int64,
52− rowElementMarkdown :: Maybe Text,
53− rowElementLatex :: Maybe Text,
54− rowElementImage :: Maybe Text,
55− rowElementQuote :: Maybe Int64,
56− rowElementAttachment :: Maybe Text
57−} deriving (GHC.Generic)
58−
59−instance SOP.Generic (ElementRow a)
60−instance SOP.HasDatatypeInfo (ElementRow a)
46+-- data ElementRow a = ElementRow {
47+-- rowElementId :: Int64, -- the source id
48+-- rowElementOrd :: Int64,
49+-- rowElementMarkdown :: Maybe Text,
50+-- rowElementLatex :: Maybe Text,
51+-- rowElementImage :: Maybe Text,
52+-- rowElementQuote :: Maybe Int64,
53+-- rowElementAttachment :: Maybe Text
54+-- } deriving (GHC.Generic)
55+
56+-- instance SOP.Generic (ElementRow a)
57+-- instance SOP.HasDatatypeInfo (ElementRow a)
6158
6259instance ToJSON (PostElement t) where
6360 toJSON (Markdown m) = object ["markdown" .= m]
@@ -75,33 +72,46 @@ instance FromJSON (PostElement t) where
7572 Attachment <$> e .: "attachment"
7673
7774
78−-- MARK: PostElementRows
75+-- -- MARK: PostElementRows
7976
80−-- TODO: After embeding id into quote
81−rowsToElements :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> [ElementRow p] -> Maybe [PostElement p]
82−rowsToElements erqs pqrs = traverse elementRowToElement . sortBy (compare `on` rowElementOrd)
83− where
84− elementRowToElement :: ElementRow a -> Maybe (PostElement a)
85− elementRowToElement (ElementRow _ _ (Just m) Nothing Nothing Nothing Nothing) = Just $ Markdown m
86− elementRowToElement (ElementRow _ _ Nothing (Just l) Nothing Nothing Nothing) = Just $ Latex l
87− elementRowToElement (ElementRow _ _ Nothing Nothing (Just i) Nothing Nothing) = Just $ Image i
88− -- elementRowToElement (ElementRow _ _ Nothing Nothing Nothing (Just q) Nothing) =
89− -- fmap Quote $ M.lookup q pqrs >>= rowsToQuote erqs pqrs
90− elementRowToElement (ElementRow _ _ Nothing Nothing Nothing Nothing (Just a)) = Just $ Attachment a
91− elementRowToElement _ = Nothing
77+type MkElementRow x = Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int64 -> Maybe Text -> x
9278
93−elementsToRows :: Int64 -> [PostElement p] -> [ElementRow p]
94−elementsToRows pId pb = map (uncurry finish) $ flip zip pb $ ElementRow pId <$> [0..]
95− where finish :: (Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int64 -> Maybe Text -> ElementRow p) -> PostElement p -> ElementRow p
96− finish f pe = case pe of
97− Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
98− Latex l -> f Nothing (Just l) Nothing Nothing Nothing
99− Image i -> f Nothing Nothing (Just i) Nothing Nothing
100− Quote q -> f Nothing Nothing Nothing (Just $ quoteId q) Nothing
101− Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
79+elemenToRow :: MkElementRow x -> PostElement p -> x
80+elemenToRow f el = case el of
81+ Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
82+ Latex l -> f Nothing (Just l) Nothing Nothing Nothing
83+ Image i -> f Nothing Nothing (Just i) Nothing Nothing
84+ Quote q -> f Nothing Nothing Nothing (Just $ quoteId q) Nothing
85+ Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
10286
87+rowsToElement :: MkElementRow (Maybe (PostElement p))
88+rowsToElement (Just m) Nothing Nothing Nothing Nothing = Just $ Markdown m
89+rowsToElement Nothing (Just l) Nothing Nothing Nothing = Just $ Latex l
90+rowsToElement Nothing Nothing (Just i) Nothing Nothing = Just $ Image i
91+-- rowsToElement Nothing Nothing Nothing (Just q) Nothing =
92+-- fmap Quote $ M.lookup q pqrs >>= rowsToQuote erqs pqrs
93+rowsToElement Nothing Nothing Nothing Nothing (Just a) = Just $ Attachment a
94+rowsToElement _ _ _ _ _ = Nothing
10395
104−-- MARK: Quote
96+data PostElementRow a = PostElementRow {
97+ rowElementId :: Int64,
98+ rowElementOrd :: Int64,
99+ rowElementMarkdown :: Maybe Text,
100+ rowElementLatex :: Maybe Text,
101+ rowElementImage :: Maybe Text,
102+ rowElementQuote :: Maybe Int64,
103+ rowElementAttachment :: Maybe Text
104+} deriving (GHC.Generic)
105+
106+instance SOP.Generic (PostElementRow a)
107+instance SOP.HasDatatypeInfo (PostElementRow a)
108+
109+
110+elementsToRows :: Int64 -> [PostElement a] -> [PostElementRow a]
111+elementsToRows pId els = map (\(el, f) -> elemenToRow f el) . zip els . map (PostElementRow pId) $ [0..]
112+
113+
114+-- -- MARK: Quote
105115
106116data PostQuote = PostQuote {
107117 quoteId :: Int64,
@@ -116,18 +126,18 @@ instance ToJSON PostQuote where
116126 "quoteBody" .= pb ]
117127
118128
119−-- MARK: PostQuoteRow
129+-- -- MARK: PostQuoteRow
120130
121−data PostQuoteRow = PostQuoteRow {
122− quoteRowId :: Int64,
123− quoteRowPostId :: Int64
124−} deriving (GHC.Generic)
131+-- data PostQuoteRow = PostQuoteRow {
132+-- quoteRowId :: Int64,
133+-- quoteRowPostId :: Int64
134+-- } deriving (GHC.Generic)
125135
126−instance SOP.Generic PostQuoteRow
127−instance SOP.HasDatatypeInfo PostQuoteRow
136+-- instance SOP.Generic PostQuoteRow
137+-- instance SOP.HasDatatypeInfo PostQuoteRow
128138
129−rowsToQuote :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostQuoteRow -> Maybe PostQuote
130−rowsToQuote erqs pqrs (PostQuoteRow qId pId) = do
131− elementRows <- M.lookup qId erqs
132− elements <- rowsToElements erqs pqrs elementRows
133− return $ PostQuote qId elements pId
139+-- rowsToQuote :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostQuoteRow -> Maybe PostQuote
140+-- rowsToQuote erqs pqrs (PostQuoteRow qId pId) = do
141+-- elementRows <- M.lookup qId erqs
142+-- elements <- rowsToElements erqs pqrs elementRows
143+-- return $ PostQuote qId elements pId
denis/src/Data/Query.hs+93−144
@@ -4,46 +4,76 @@
44 OverloadedLabels,
55 OverloadedStrings ,
66 TypeApplications ,
7− TypeOperators #-}
7+ TypeOperators,
8+ PartialTypeSignatures #-}
9+
10+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
11+
812
913module Data.Query (
1014 Schema,
1115 createTables,
1216 getPost,
1317 getUser,
14− createDraft,
15− updateDraft,
16− publishDraft,
17− getDrafts,
1818 getLastPosts,
19− getPostsForUser
19+ getPostsForUser,
20+ Limit,
21+ publishPost
2022) where
2123
2224import Squeal.PostgreSQL
2325import Data.User
2426import Data.Post
2527import Data.Schema
26−-- import Data.Function (on)
27−import qualified Data.Map.Lazy as M
28+import Data.Function (on)
2829import Data.Connection
2930import Data.PostElement
3031import qualified Servant as S
3132import Control.Monad.Morph
32−import Data.Maybe
3333import Data.Word (Word64)
34+import qualified Data.List as L
35+
36+
37+-- MARK: Generalized Post Queries
38+
39+type TableEndo schema params from grouping = TableExpression schema params from grouping ->
40+ TableExpression schema params from grouping
41+
42+postsQ :: TableEndo Schema params _ 'Ungrouped -> Query Schema params _
43+postsQ te = selectStar $ te (from $ table #posts)
3444
45+postViewT :: TableEndo Schema params _ 'Ungrouped -> TableExpression Schema params _ 'Ungrouped
46+postViewT te = from $ subquery (postsQ te `As` #posts) &
47+ innerJoin (table #postElements)
48+ (#posts ! #postRowId .== #postElements ! #rowElementId)
3549
36−getQuoteRowsQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG (ElementRow Post))
37−getQuoteRowsQ = UnsafeQuery "WITH RECURSIVE getQuote AS ( \
38− \SELECT * FROM \"quoteElements\" quote WHERE \"rowElementId\" = $1 \
39− \UNION ALL \
40− \SELECT newQuote.* FROM \"quoteElements\" newQuote \
41− \INNER JOIN getQuote q ON q.\"rowElementQuote\" = newQuote.\"rowElementId\" \
42− \) \
43− \SELECT * FROM getQuote"
50+getPostQ :: TableEndo Schema params _ 'Ungrouped -> TableEndo Schema params _ 'Ungrouped -> Query Schema params (RowPG PostRowResponse)
51+getPostQ oTe te = select (
52+ #posts ! #postRowId :*
53+ #posts ! #postRowAuthorId :*
54+ -- #rowElementId :*
55+ #postElements ! #rowElementOrd :*
56+ #postElements ! #rowElementMarkdown :*
57+ #postElements ! #rowElementLatex :*
58+ #postElements ! #rowElementImage :*
59+ #postElements ! #rowElementQuote :*
60+ #postElements ! #rowElementAttachment)
61+ (oTe $ postViewT te)
4462
45−getQuoteQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG PostQuoteRow)
46−getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1)
63+
64+-- MARK: Concrete Queries
65+
66+-- getQuoteRowsQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG (ElementRow Post))
67+-- getQuoteRowsQ = UnsafeQuery "WITH RECURSIVE getQuote AS ( \
68+-- \SELECT * FROM \"quoteElements\" quote WHERE \"rowElementId\" = $1 \
69+-- \UNION ALL \
70+-- \SELECT newQuote.* FROM \"quoteElements\" newQuote \
71+-- \INNER JOIN getQuote q ON q.\"rowElementQuote\" = newQuote.\"rowElementId\" \
72+-- \) \
73+-- \SELECT * FROM getQuote"
74+
75+-- getQuoteQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG PostQuoteRow)
76+-- getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1)
4777
4878-- getQuote :: QuoteId -> PQ Quote
4979-- getQuote qId = do
@@ -55,62 +85,27 @@ getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1
5585getUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG User)
5686getUserQ = selectStar $ from (table #users) & where_ (#userId .== param @1)
5787
58−getPostRowQ :: Query Schema (TuplePG (Only PostId)) (RowPG PostRow)
59−getPostRowQ = selectStar $ from (table #posts) & where_ (#postRowId .== param @1)
60−
61−getDraftRowQ :: Query Schema (TuplePG (Only DraftId)) (RowPG PostRow)
62−getDraftRowQ = selectStar $ from (table #drafts) & where_ (#postRowId .== param @1)
63−
64−getPostElementsQ :: Query Schema (TuplePG (Only PostId)) (RowPG (ElementRow Post))
65−getPostElementsQ = selectStar $ from (table #postElements) & where_ (#rowElementId .== param @1)
88+getPostByIdQ :: Query Schema (TuplePG (Only PostId)) (RowPG PostRowResponse)
89+getPostByIdQ = getPostQ id $ where_ $ #postRowId .== param @1
6690
67−getDraftElementsQ :: Query Schema (TuplePG (Only DraftId)) (RowPG (ElementRow Draft))
68−getDraftElementsQ = selectStar $ from (table #draftElements) & where_ (#rowElementId .== param @1)
91+type Limit = Word64
6992
70−getPost :: PostId -> StaticPQ (Maybe Post)
71−getPost pId = do
72− postRow <- runQueryParams getPostRowQ (Only pId) >>= getRow 0
73− postRowElements <- runQueryParams getPostElementsQ (Only pId) >>= getRows
74− return $ rowsToPost M.empty M.empty postRow postRowElements
75−
76−getLastPostRowsQ :: Word64 -> Query Schema '[] (RowPG (Only PostId))
77−getLastPostRowsQ n = select (#postRowId `as` #fromOnly) $
78− (from $ table #posts) &
79− orderBy [#postRowId & Desc] &
80− limit n
81−
82−getLastPosts :: Word64 -> StaticPQ [Post]
83−getLastPosts n = do
84− postIds <- runQuery (getLastPostRowsQ n) >>= getRows
85− catMaybes <$> traverse getPost (map fromOnly postIds)
86−
87−getUser :: UserId -> StaticPQ User
88−getUser uId = runQueryParams getUserQ (Only uId) >>= getRow 0
89−
90−
91−createDraftRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
92−createDraftRowQ = insertRow #drafts
93− (Default `as` #postRowId :* Set (param @1) `as` #postRowAuthorId)
94− OnConflictDoRaise
95− (Returning $ #postRowId `as` #fromOnly)
93+getLastNPostsQ :: Limit -> Query Schema params (RowPG PostRowResponse)
94+getLastNPostsQ lim = getPostQ
95+ (limit lim . orderBy [#posts ! #postRowId & Desc]) id
9696
97+getLastNPostsForUserQ :: Limit -> Query Schema (TuplePG (Only UserId)) (RowPG PostRowResponse)
98+getLastNPostsForUserQ lim = getPostQ
99+ (limit lim . orderBy [#posts ! #postRowId & Desc])
100+ (where_ $ #postRowAuthorId .== param @1)
101+
97102createPostRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only PostId))
98103createPostRowQ = insertRow #posts
99104 (Default `as` #postRowId :* Set (param @1) `as` #postRowAuthorId)
100105 OnConflictDoRaise
101106 (Returning $ #postRowId `as` #fromOnly)
102107
103−createDraftElementRowsQ :: Manipulation Schema (TuplePG (ElementRow Draft)) '[]
104−createDraftElementRowsQ = insertRow_ #draftElements
105− (Set (param @1) `as` #rowElementId :*
106− Set (param @2) `as` #rowElementOrd :*
107− Set (param @3) `as` #rowElementMarkdown :*
108− Set (param @4) `as` #rowElementLatex :*
109− Set (param @5) `as` #rowElementImage :*
110− Set (param @6) `as` #rowElementQuote :*
111− Set (param @7) `as` #rowElementAttachment)
112−
113−createPostElementRowsQ :: Manipulation Schema (TuplePG (ElementRow Post)) '[]
108+createPostElementRowsQ :: Manipulation Schema (TuplePG (PostElementRow Post)) '[]
114109createPostElementRowsQ = insertRow_ #postElements
115110 (Set (param @1) `as` #rowElementId :*
116111 Set (param @2) `as` #rowElementOrd :*
@@ -120,84 +115,38 @@ createPostElementRowsQ = insertRow_ #postElements
120115 Set (param @6) `as` #rowElementQuote :*
121116 Set (param @7) `as` #rowElementAttachment)
122117
123−createDraft :: UserId -> [PostElement Draft] -> StaticPQ Draft
124−createDraft uId els = transactionally_ $ do
125− dId' <- manipulateParams createDraftRowQ (Only uId)
126− dId <- lift $ fromOnly <$> getRow 0 dId'
127− traversePrepared_ createDraftElementRowsQ $ elementsToRows dId els
128− return $ mkDraft dId uId els
129−
130−getDraftsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
131−getDraftsForUserQ = select (#postRowId `as` #fromOnly) $
132− (from $ table #drafts) &
133− where_ (#postRowAuthorId .== param @1)
134−
135−getPostsForUserLimitingQ :: Word64 -> Query Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
136−getPostsForUserLimitingQ lim = select (#postRowId `as` #fromOnly) $
137− (from $ table #posts) &
138− where_ (#postRowAuthorId .== param @1) &
139− orderBy [#postRowId & Desc] &
140− limit lim
141−
142−getPostsForUser :: Word64 -> UserId -> StaticPQ [Post]
118+-- MARK: FrontEnd functions
119+
120+getPostsForUser :: Word64 -> UserId -> StaticPQ (Maybe [Post])
143121getPostsForUser lim uId = do
144− postIds <- runQueryParams (getPostsForUserLimitingQ lim) (Only uId) >>= getRows
145− catMaybes <$> traverse getPost (map fromOnly postIds)
146−
122+ postRows <- runQueryParams (getLastNPostsForUserQ lim) (Only uId) >>= getRows
123+ return . foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId) $ postRows
124+
125+getPost :: PostId -> StaticPQ (Maybe Post)
126+getPost pId = do
127+ postRow <- runQueryParams getPostByIdQ (Only pId) >>= getRows
128+ return $ rowsToPost postRow
147129
148−getDraft :: DraftId -> StaticPQ (Maybe Draft)
149−getDraft dId = do
150− draftRow <- runQueryParams getDraftRowQ (Only dId) >>= getRow 0
151− draftRowElements <- runQueryParams getDraftElementsQ (Only dId) >>= getRows
152− return $ rowsToPost M.empty M.empty draftRow draftRowElements
153−
154−getDrafts :: UserId -> StaticPQ [Draft]
155−getDrafts uId = do
156− draftRow <- runQueryParams getDraftsForUserQ (Only uId) >>= getRows
157− catMaybes <$> traverse getDraft (map fromOnly draftRow)
158−
159−getDraftForUserWithIdQ :: Query Schema (TuplePG (UserId, DraftId)) (RowPG PostRow)
160−getDraftForUserWithIdQ = selectStar $
161− (from $ table #drafts) &
162− where_ (#postRowAuthorId .== param @1 .&& #postRowId .== param @2)
163−
164−deleteElementsForIdQ :: Manipulation Schema (TuplePG (Only DraftId)) '[]
165−deleteElementsForIdQ = deleteFrom_ #draftElements (#rowElementId .== param @1)
166−
167−deleteDraftQ :: Manipulation Schema (TuplePG (Only DraftId)) '[]
168−deleteDraftQ = deleteFrom_ #drafts (#postRowId .== param @1)
169−
170−updateDraft :: UserId -> DraftId -> [PostElement Draft] -> StaticPQ ()
171−updateDraft uId dId els = transactionally_ $ do
172− rs <- runQueryParams getDraftForUserWithIdQ (uId, dId) >>= getRows
173− let c = length (rs :: [PostRow])
174− if c /= 1 then
175− lift $ S.throwError S.err404
176− else do
177− _ <- manipulateParams deleteElementsForIdQ (Only dId)
178− traversePrepared_ createDraftElementRowsQ $ elementsToRows dId els
179−
180−getDraftElementRowsQ :: Query Schema (TuplePG (Only DraftId)) (RowPG (ElementRow Draft))
181−getDraftElementRowsQ = selectStar $
182− (from $ table #draftElements) &
183− where_ (#rowElementId .== param @1) &
184− orderBy [#rowElementOrd & Asc]
185−
186−publishDraft :: UserId -> DraftId -> StaticPQ ()
187−publishDraft uId dId = transactionally_ $ do
188− rs <- runQueryParams getDraftForUserWithIdQ (uId, dId) >>= getRows
189− let c = length (rs :: [PostRow])
190− if c /= 1 then
191− lift $ S.throwError S.err404
192− else do
193− els <- runQueryParams getDraftElementRowsQ (Only dId) >>= getRows
194− pId' <- manipulateParams createPostRowQ (Only uId)
195− pId <- lift $ fromOnly <$> getRow 0 pId'
196− traversePrepared_ createPostElementRowsQ $ map (fromDraft pId) els
197− _ <- manipulateParams deleteDraftQ (Only dId)
198− return ()
199−
200−
201−-- tupleFirst :: (a -> b) -> a -> (b, a)
202−-- tupleFirst f x = (f x, x)
130+getLastPosts :: Word64 -> StaticPQ (Maybe [Post])
131+getLastPosts n = do
132+ postRows <- runQuery (getLastNPostsQ n) >>= getRows
133+ return . foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId) $ postRows
203134
135+getUser :: UserId -> StaticPQ User
136+getUser uId = runQueryParams getUserQ (Only uId) >>= getRow 0
137+
138+publishPost :: UserId -> [PostElement Post] -> StaticPQ PostId
139+publishPost uId els = transactionally_ $ do
140+ pId' <- manipulateParams createPostRowQ (Only uId) >>= firstRow
141+ case pId' of
142+ (Just (Only pId)) -> do
143+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId els
144+ return pId
145+ _ -> lift $ S.throwError S.err404
146+
147+-- MARK: Utils
148+
149+foldMaybe :: [Maybe a] -> Maybe [a]
150+foldMaybe [] = Just []
151+foldMaybe (Nothing : _) = Nothing
152+foldMaybe (Just x : xs) = (x :) <$> foldMaybe xs
denis/src/Data/Schema.hs+32−43
@@ -4,7 +4,10 @@
44 OverloadedLabels,
55 OverloadedStrings ,
66 TypeApplications ,
7− TypeOperators #-}
7+ TypeOperators,
8+ OverloadedStrings,
9+ KindSignatures #-}
10+
811
912module Data.Schema (
1013 Schema,
@@ -37,13 +40,6 @@ type Schema =
3740 "quoteRowId" ::: 'Def :=> 'NotNull 'PGint8,
3841 "quoteRowPostId" ::: 'NoDef :=> 'NotNull 'PGint8
3942 ]),
40− "drafts" ::: 'Table ( '[
41− "pk_drafts" ::: 'PrimaryKey '["postRowId"],
42− "fk_draft_author_id" ::: 'ForeignKey '["postRowAuthorId"] "users" '["userId"]] :=>
43− '[
44− "postRowId" ::: 'Def :=> 'NotNull 'PGint8,
45− "postRowAuthorId" ::: 'NoDef :=> 'NotNull 'PGint8
46− ]),
4743 "postElements" ::: 'Table (
4844 '[
4945 "fk_post_quote_self_id" ::: 'ForeignKey '["rowElementId"] "posts" '["postRowId"],
@@ -75,24 +71,20 @@ type Schema =
7571 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
7672 "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
7773 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
78− ]),
79− "draftElements" ::: 'Table (
80− '[
81− "fk_draft_quote_self_id" ::: 'ForeignKey '["rowElementId"] "drafts" '["postRowId"],
82− "fk_draft_quote_id" ::: 'ForeignKey '["rowElementQuote"] "quotes" '["quoteRowId"]
83− -- ,
84− -- "unique_post_quote" ::: 'Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"]
85− ] :=>
86− '[
87− "rowElementId" ::: 'NoDef :=> 'NotNull 'PGint8,
88− "rowElementOrd" ::: 'NoDef :=> 'NotNull 'PGint8,
89− "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,
90− "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,
91− "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
92− "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
93− "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
74+ -- ]),
75+ -- "postsView" ::: 'View (RowPG PostRowResponse)
76+ -- ('[
77+ -- "postRowId" ::: 'NotNull 'PGint8,
78+ -- "postRowAuthorId" ::: 'NotNull 'PGint8,
79+ -- "rowElementId" ::: 'NotNull 'PGint8,
80+ -- "rowElementOrd" ::: 'NotNull 'PGint8,
81+ -- "rowElementMarkdown" ::: 'Null 'PGtext,
82+ -- "rowElementLatex" ::: 'Null 'PGtext,
83+ -- "rowElementImage" ::: 'Null 'PGtext,
84+ -- "rowElementQuote" ::: 'Null 'PGint8,
85+ -- "rowElementAttachment" ::: 'Null 'PGtext
9486 ])
95−
87+
9688 ]
9789
9890
@@ -115,12 +107,6 @@ createTables = createTable #users (
115107 ) (
116108 primaryKey #quoteRowId `as` #pk_post_quotes :*
117109 foreignKey #quoteRowPostId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_post_id
118− ) >>> createTable #drafts (
119− serial8 `as` #postRowId :*
120− notNullable int8 `as` #postRowAuthorId
121− ) (
122− primaryKey #postRowId `as` #pk_drafts :*
123− foreignKey #postRowAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_draft_author_id
124110 ) >>> createTable #postElements (
125111 notNullable int8 `as` #rowElementId :*
126112 notNullable int8 `as` #rowElementOrd :*
@@ -143,18 +129,21 @@ createTables = createTable #users (
143129 ) (
144130 foreignKey #rowElementId #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quotes_quote_self_id :*
145131 foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_quote_id
146− ) >>> createTable #draftElements (
147− notNullable int8 `as` #rowElementId :*
148− notNullable int8 `as` #rowElementOrd :*
149− nullable text `as` #rowElementMarkdown :*
150− nullable text `as` #rowElementLatex :*
151− nullable text `as` #rowElementImage :*
152− nullable int8 `as` #rowElementQuote :*
153− nullable text `as` #rowElementAttachment
154− ) (
155− foreignKey #rowElementId #drafts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_draft_quote_self_id :*
156− foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_draft_quote_id
157− )
132+ -- ) >>> createView #postsView (select (
133+ -- #posts ! #postRowId :*
134+ -- #posts ! #postRowAuthorId :*
135+ -- -- #rowElementId :*
136+ -- #postElements ! #rowElementOrd :*
137+ -- #postElements ! #rowElementMarkdown :*
138+ -- #postElements ! #rowElementLatex :*
139+ -- #postElements ! #rowElementImage :*
140+ -- #postElements ! #rowElementQuote :*
141+ -- #postElements ! #rowElementAttachment
142+ -- ) (
143+ -- from ((table #posts) &
144+ -- (innerJoin (table #postElements)
145+ -- (#posts ! #postRowId .== #postElements ! #rowElementId))))
146+ )
158147-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])
159148-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $
160149-- ((ifThenElse (isNull #rowElementOrd) 1 0) +
denis/src/Server/API.hs+2−5
@@ -21,7 +21,6 @@ import Servant.Server
2121import Data.Connection
2222import Data.Query
2323import Server.App
24−import Server.API.Draft
2524import Server.API.Posts
2625import Server.Logger
2726import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))
@@ -42,8 +41,7 @@ type API =
4241 "authenticate" :> AuthenticationHandler :<|>
4342 Authentication :> (
4443 "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>
45− "posts" :> PostApi :<|>
46− "drafts" :> DraftApi
44+ "posts" :> PostApi
4745 )
4846
4947serverProxy :: Proxy API
@@ -54,8 +52,7 @@ mkServerAPI l =
5452 l :<|>
5553 authenticate :<|> (\uId ->
5654 mapM (runQnotFound . getUser) :<|>
57− postApi uId :<|>
58− draftApi uId
55+ postApi uId
5956 )
6057
6158-- getPostsS :: [UserId] -> App [User]
denis/src/Server/API/Draft.hsdeleted−78
@@ -1,78 +0,0 @@
1−{-# LANGUAGE
2− DataKinds ,
3− DeriveGeneric ,
4− OverloadedLabels,
5− OverloadedStrings ,
6− TypeApplications ,
7− TypeOperators #-}
8−
9−module Server.API.Draft (
10− DraftApi,
11− draftApi,
12− DraftUpdate(..)
13−) where
14−
15−import Data.Proxy
16−import Servant.API
17−import qualified Data.Post as P
18−import Data.Aeson
19−import GHC.Generics
20−import Server.App
21−import Servant.Server
22−import Data.Query
23−import Data.User
24−import Data.Connection
25−import Servant.Docs (ToSample, toSamples, samples)
26−
27−-- MARK: Documentation
28−
29−instance ToSample DraftUpdate where
30− toSamples _ = samples $ [DraftUpdate 8] <*> (map snd $ toSamples Proxy)
31−
32−-- MARK: Implementation
33−
34−data DraftUpdate = DraftUpdate {
35− draftId :: P.DraftId,
36− draftContent :: [P.PostElement P.Draft]
37− } deriving Generic
38−
39−instance FromJSON DraftUpdate where
40− parseJSON = withObject "Post update object" $ \e ->
41− DraftUpdate <$> e .: "id" <*> e.: "body"
42−instance ToJSON DraftUpdate where
43− toJSON (DraftUpdate dId body) = object [
44− "id" .= dId,
45− "body" .= body
46− ]
47−
48−
49−type DraftApi = "create" :> ReqBody '[JSON] [P.PostElement P.Draft] :> Post '[JSON] P.DraftId :<|>
50− "update" :> ReqBody '[JSON] DraftUpdate :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
51− "publish" :> ReqBody '[JSON] P.DraftId :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
52− "all" :> Post '[JSON] [DraftUpdate] :<|>
53− "createAndPublish" :> ReqBody '[JSON] [P.PostElement P.Draft] :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent
54−
55−draftApi :: UserId -> ServerT DraftApi App
56−draftApi uId =
57− (fmap P.postId . runQnotFound . createDraft uId) :<|> updateDraftApi uId :<|>
58− publishDraftApi uId :<|>
59− runQnotFound (fmap (map postToDraft) $ getDrafts uId) :<|>
60− createAndPublish uId
61−
62−updateDraftApi :: UserId -> DraftUpdate -> App NoContent
63−updateDraftApi uId (DraftUpdate dId els) = do
64− runQnotFound $ updateDraft uId dId els
65− return NoContent
66−
67−publishDraftApi :: UserId -> P.DraftId -> App NoContent
68−publishDraftApi uId dId = do
69− runQnotFound $ publishDraft uId dId
70− return NoContent
71−
72−postToDraft :: P.Draft -> DraftUpdate
73−postToDraft (P.PostData dId _ body) = DraftUpdate dId body
74−
75−createAndPublish :: UserId -> [P.PostElement P.Draft] -> App NoContent
76−createAndPublish uId els = do
77− dId <- fmap P.postId . runQnotFound . createDraft uId $ els
78− publishDraftApi uId dId
denis/src/Server/API/Posts.hs+8−4
@@ -44,7 +44,8 @@ instance FromJSON UserPostsRequest where
4444
4545type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] [P.Post] :<|>
4646 "last" :> ReqBody '[JSON] Word64 :> Post '[JSON] [P.Post] :<|>
47− "forUser" :> ReqBody '[JSON] UserPostsRequest :> Post '[JSON] [P.Post]
47+ "forUser" :> ReqBody '[JSON] UserPostsRequest :> Post '[JSON] [P.Post] :<|>
48+ "publish" :> ReqBody '[JSON] [P.PostElement P.Post] :> Post '[JSON] P.PostId
4849
4950maybeNotFound :: App (Maybe a) -> App a
5051maybeNotFound = (>>= (\t -> case t of
@@ -53,13 +54,16 @@ maybeNotFound = (>>= (\t -> case t of
5354
5455
5556postApi :: UserId -> ServerT PostApi App
56−postApi uId = getPosts :<|> lastPosts :<|> getPostsForUserApi
57+postApi uId = getPosts :<|> lastPosts :<|> getPostsForUserApi :<|> publishPostApi uId
5758
5859getPosts :: [P.PostId] -> App [P.Post]
5960getPosts = mapM (maybeNotFound . runQnotFound . getPost)
6061
6162lastPosts :: Word64 -> App [P.Post]
62−lastPosts = runQnotFound . getLastPosts
63+lastPosts = maybeNotFound . runQnotFound . getLastPosts
6364
6465getPostsForUserApi :: UserPostsRequest -> App [P.Post]
65−getPostsForUserApi (UserPostsRequest uId lim) = runQnotFound $ getPostsForUser lim uId
66+getPostsForUserApi (UserPostsRequest uId lim) = maybeNotFound . runQnotFound $ getPostsForUser lim uId
67+
68+publishPostApi :: UserId -> [P.PostElement P.Post] -> App P.PostId
69+publishPostApi uId = runQerror . publishPost uId
stack.yaml+2−2
@@ -37,8 +37,8 @@ packages:
3737# Dependency packages to be pulled from upstream that are not in the resolver
3838# using the same syntax as the packages field.
3939# (e.g., acme-missiles-0.3)
40−extra-deps:
41−- servant-options-0.1.0.0
40+# extra-deps:
41+# - servant-options-0.1.0.0
4242
4343
4444# Override default flag values for local packages and extra-deps