git.iko.soy/denis
on master help sign in
Resolved #1.
77d5daciko
denis/docs/Docs.hs−1
compare with master
unifiedsplit
@@ -19,7 +19,6 @@ import Data.User
19import Data.Int (Int64)
19import Data.Int (Int64)
20import Data.Word (Word64)
20import Data.Word (Word64)
21import Server.API.Posts
21import Server.API.Posts
22−import Server.API.Draft
23import Server.Logger
22import Server.Logger
24
23
25main = writeFile "docs.md" . markdown . docs . pretty $ serverProxy
24main = writeFile "docs.md" . markdown . docs . pretty $ serverProxy
denis/src/Data/Connection.hs+5−1
@@ -11,7 +11,8 @@ module Data.Connection (
11 StaticPQ,
11 StaticPQ,
12 runQ,
12 runQ,
13 runQ',
13 runQ',
14− runQnotFound
14+ runQnotFound,
15+ runQerror
15) where
16) where
16
17
17import Squeal.PostgreSQL
18import Squeal.PostgreSQL
@@ -33,3 +34,6 @@ runQ' conn err req = handleSqueal (const $ throwError err) $ runPoolPQ req conn
33
34
34runQnotFound :: StaticPQ a -> App a
35runQnotFound :: StaticPQ a -> App a
35runQnotFound = runQ err404
36runQnotFound = runQ err404
37+
38+runQerror :: StaticPQ a -> App a
39+runQerror = runQ err500
denis/src/Data/Post.hs+41−47
@@ -5,66 +5,52 @@
5 OverloadedStrings ,
5 OverloadedStrings ,
6 TypeApplications ,
6 TypeApplications ,
7 TypeOperators,
7 TypeOperators,
8− OverloadedStrings,
8+ OverloadedStrings #-}
9− KindSignatures #-}
10
9
11module Data.Post (
10module Data.Post (
12− Post,
11+ Post(..),
13 PostElement,
12 PostElement,
14− PostQuote(..),
13+ -- PostQuote(..),
15− PostRow,
14+ -- PostRow,
16− PostQuoteRow,
15+ -- PostQuoteRow,
17− ElementRow,
16+ -- ElementRow,
18− postToRow,
17+ postToRows,
19− postToElementRows,
18+ -- postToElementRows,
20 rowsToPost,
19 rowsToPost,
21 PostId,
20 PostId,
22 QuoteId,
21 QuoteId,
23− Draft,
22+ PostRowResponse(..),
24− DraftId,
25− mkDraft,
26− fromDraft,
27− PostData(..)
28) where
23) where
29
24
30import Data.Int (Int64)
25import Data.Int (Int64)
31import qualified Generics.SOP as SOP
26import qualified Generics.SOP as SOP
32import qualified GHC.Generics as GHC
27import qualified GHC.Generics as GHC
33import Data.Aeson
28import Data.Aeson
34−import qualified Data.Map.Lazy as M
35import Servant.Docs (ToSample, toSamples, samples)
29import Servant.Docs (ToSample, toSamples, samples)
36import Data.Proxy
30import Data.Proxy
37−
38import Data.PostElement
31import Data.PostElement
32+import Data.Text (Text)
33+import Data.Function (on)
39
34
40-- MARK: Documentation
35-- MARK: Documentation
41
36
42−instance ToSample (PostData a) where
37+instance ToSample Post where
43− toSamples _ = samples $ [PostData 8 17] <*> (map snd $ toSamples Proxy)
38+ toSamples _ = samples $ [Post 8 17] <*> (map snd $ toSamples Proxy)
44
39
45
40
46-- MARK: Actual type
41-- MARK: Actual type
47
42
48type PostId = Int64
43type PostId = Int64
49type QuoteId = Int64
44type QuoteId = Int64
50−type DraftId = Int64
51−
52−data PostType = Draft | NonDraft
53
45
54−data PostData (p :: PostType) = PostData {
46+data Post = Post {
55 postId :: Int64,
47 postId :: Int64,
56 postAuthorId :: Int64,
48 postAuthorId :: Int64,
57− postBody :: [PostElement (PostData p)]
49+ postBody :: [PostElement Post]
58}
50}
59
51
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
52+instance ToJSON Post where
67− toJSON (PostData pId aId pb) = object [
53+ toJSON (Post pId aId pb) = object [
68 "id" .= pId,
54 "id" .= pId,
69 "authorId" .= aId,
55 "authorId" .= aId,
70 "body" .= pb ]
56 "body" .= pb ]
@@ -72,25 +58,33 @@ instance ToJSON (PostData p) where
72
58
73-- MARK: Rows
59-- MARK: Rows
74
60
75−data PostRow = PostRow {
61+-- Need to manually maintain. Future: https://github.com/morphismtech/squeal/issues/96
62+
63+data PostRowResponse = PostRowResponse {
64+ -- PostRow
76 postRowId :: Int64,
65 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
78} deriving (GHC.Generic)
75} deriving (GHC.Generic)
79
76
80−instance SOP.Generic PostRow
77+instance SOP.Generic PostRowResponse
81−instance SOP.HasDatatypeInfo PostRow
78+instance SOP.HasDatatypeInfo PostRowResponse
82−
83−postToRow :: Post -> PostRow
84−postToRow (PostData pId aId _) = PostRow pId aId
85
79
86−postToElementRows :: PostData p -> [ElementRow (PostData p)]
80+unRow :: MkElementRow x -> PostRowResponse -> x
87−postToElementRows (PostData pId _ pb) = elementsToRows pId pb
81+unRow f' (PostRowResponse _ _ _ a b c d e) = f' a b c d e
88
82
89−rowsToPost :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostRow -> [ElementRow (PostData p)] -> Maybe (PostData p)
83+postToRows :: Post -> [PostRowResponse]
90−rowsToPost erqs pqrs (PostRow pId aId) elementRows = PostData pId aId <$> rowsToElements erqs pqrs elementRows
84+postToRows (Post pId uId els) = map (\(el, f) -> elemenToRow f el) . zip els . map (PostRowResponse pId uId) $ [0..]
91
85
92−fromDraft :: PostId -> ElementRow Draft -> ElementRow Post
86+rowsToPost :: [PostRowResponse] -> Maybe Post
93−fromDraft pId (ElementRow _ b c d e f g) = ElementRow pId b c d e f g
87+rowsToPost [] = Nothing
94−
88+rowsToPost (el:els) = if all (((==) `on` postRowId) el) els
95−-- tupleFirst :: (a -> b) -> a -> (b, a)
89+ then Post (postRowId el) (postRowAuthorId el) <$> traverse (unRow rowsToElement) (el:els)
96−-- tupleFirst f a = (f a, a)
90+ else Nothing
denis/src/Data/PostElement.hs+65−55
@@ -10,11 +10,11 @@
10
10
11module Data.PostElement (
11module Data.PostElement (
12 PostElement,
12 PostElement,
13− ElementRow(..),
13+ elemenToRow,
14+ rowsToElement,
15+ MkElementRow,
16+ PostElementRow(..),
14− elementsToRows,
17+ elementsToRows
15− PostQuoteRow(..),
16− PostQuote(..),
17− rowsToElements
18) where
18) where
19
19
20import Data.Int (Int64)
20import Data.Int (Int64)
@@ -22,9 +22,6 @@ import qualified Generics.SOP as SOP
22import qualified GHC.Generics as GHC
22import qualified GHC.Generics as GHC
23import Data.Text (Text)
23import Data.Text (Text)
24import Data.Aeson
24import Data.Aeson
25−import qualified Data.Map.Lazy as M
26−import Data.List (sortBy)
27−import Data.Function (on)
28import Control.Applicative ((<|>))
25import Control.Applicative ((<|>))
29import Servant.Docs (ToSample, toSamples, samples)
26import Servant.Docs (ToSample, toSamples, samples)
30
27
@@ -46,18 +43,18 @@ data PostElement a = Markdown Text
46 | Attachment Text
43 | Attachment Text
47
44
48
45
49−data ElementRow a = ElementRow {
46+-- data ElementRow a = ElementRow {
50− rowElementId :: Int64, -- the source id
47+-- rowElementId :: Int64, -- the source id
51− rowElementOrd :: Int64,
48+-- rowElementOrd :: Int64,
52− rowElementMarkdown :: Maybe Text,
49+-- rowElementMarkdown :: Maybe Text,
53− rowElementLatex :: Maybe Text,
50+-- rowElementLatex :: Maybe Text,
54− rowElementImage :: Maybe Text,
51+-- rowElementImage :: Maybe Text,
55− rowElementQuote :: Maybe Int64,
52+-- rowElementQuote :: Maybe Int64,
56− rowElementAttachment :: Maybe Text
53+-- rowElementAttachment :: Maybe Text
57−} deriving (GHC.Generic)
54+-- } deriving (GHC.Generic)
58−
55+
59−instance SOP.Generic (ElementRow a)
56+-- instance SOP.Generic (ElementRow a)
60−instance SOP.HasDatatypeInfo (ElementRow a)
57+-- instance SOP.HasDatatypeInfo (ElementRow a)
61
58
62instance ToJSON (PostElement t) where
59instance ToJSON (PostElement t) where
63 toJSON (Markdown m) = object ["markdown" .= m]
60 toJSON (Markdown m) = object ["markdown" .= m]
@@ -75,33 +72,46 @@ instance FromJSON (PostElement t) where
75 Attachment <$> e .: "attachment"
72 Attachment <$> e .: "attachment"
76
73
77
74
78−-- MARK: PostElementRows
75+-- -- MARK: PostElementRows
79
76
80−-- TODO: After embeding id into quote
77+type MkElementRow x = Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int64 -> Maybe Text -> x
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
92
78
93−elementsToRows :: Int64 -> [PostElement p] -> [ElementRow p]
79+elemenToRow :: MkElementRow x -> PostElement p -> x
94−elementsToRows pId pb = map (uncurry finish) $ flip zip pb $ ElementRow pId <$> [0..]
80+elemenToRow f el = case el of
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
81+ Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
98− Latex l -> f Nothing (Just l) Nothing Nothing Nothing
82+ Latex l -> f Nothing (Just l) Nothing Nothing Nothing
99− Image i -> f Nothing Nothing (Just i) Nothing Nothing
83+ Image i -> f Nothing Nothing (Just i) Nothing Nothing
100− Quote q -> f Nothing Nothing Nothing (Just $ quoteId q) Nothing
84+ Quote q -> f Nothing Nothing Nothing (Just $ quoteId q) Nothing
101− Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
85+ Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
102
86
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
103
95
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+
104−-- MARK: Quote
114+-- -- MARK: Quote
105
115
106data PostQuote = PostQuote {
116data PostQuote = PostQuote {
107 quoteId :: Int64,
117 quoteId :: Int64,
@@ -116,18 +126,18 @@ instance ToJSON PostQuote where
116 "quoteBody" .= pb ]
126 "quoteBody" .= pb ]
117
127
118
128
119−-- MARK: PostQuoteRow
129+-- -- MARK: PostQuoteRow
120
130
121−data PostQuoteRow = PostQuoteRow {
131+-- data PostQuoteRow = PostQuoteRow {
122− quoteRowId :: Int64,
132+-- quoteRowId :: Int64,
123− quoteRowPostId :: Int64
133+-- quoteRowPostId :: Int64
124−} deriving (GHC.Generic)
134+-- } deriving (GHC.Generic)
125
135
126−instance SOP.Generic PostQuoteRow
136+-- instance SOP.Generic PostQuoteRow
127−instance SOP.HasDatatypeInfo PostQuoteRow
137+-- instance SOP.HasDatatypeInfo PostQuoteRow
128
138
129−rowsToQuote :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostQuoteRow -> Maybe PostQuote
139+-- rowsToQuote :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostQuoteRow -> Maybe PostQuote
130−rowsToQuote erqs pqrs (PostQuoteRow qId pId) = do
140+-- rowsToQuote erqs pqrs (PostQuoteRow qId pId) = do
131− elementRows <- M.lookup qId erqs
141+-- elementRows <- M.lookup qId erqs
132− elements <- rowsToElements erqs pqrs elementRows
142+-- elements <- rowsToElements erqs pqrs elementRows
133− return $ PostQuote qId elements pId
143+-- return $ PostQuote qId elements pId
denis/src/Data/Query.hs+93−144
@@ -4,46 +4,76 @@
4 OverloadedLabels,
4 OverloadedLabels,
5 OverloadedStrings ,
5 OverloadedStrings ,
6 TypeApplications ,
6 TypeApplications ,
7− TypeOperators #-}
7+ TypeOperators,
8+ PartialTypeSignatures #-}
9+
10+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
11+
8
12
9module Data.Query (
13module Data.Query (
10 Schema,
14 Schema,
11 createTables,
15 createTables,
12 getPost,
16 getPost,
13 getUser,
17 getUser,
14− createDraft,
15− updateDraft,
16− publishDraft,
17− getDrafts,
18 getLastPosts,
18 getLastPosts,
19− getPostsForUser
19+ getPostsForUser,
20+ Limit,
21+ publishPost
20) where
22) where
21
23
22import Squeal.PostgreSQL
24import Squeal.PostgreSQL
23import Data.User
25import Data.User
24import Data.Post
26import Data.Post
25import Data.Schema
27import Data.Schema
26−-- import Data.Function (on)
28+import Data.Function (on)
27−import qualified Data.Map.Lazy as M
28import Data.Connection
29import Data.Connection
29import Data.PostElement
30import Data.PostElement
30import qualified Servant as S
31import qualified Servant as S
31import Control.Monad.Morph
32import Control.Monad.Morph
32−import Data.Maybe
33import Data.Word (Word64)
33import 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)
34
44
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)
35
49
36−getQuoteRowsQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG (ElementRow Post))
50+getPostQ :: TableEndo Schema params _ 'Ungrouped -> TableEndo Schema params _ 'Ungrouped -> Query Schema params (RowPG PostRowResponse)
37−getQuoteRowsQ = UnsafeQuery "WITH RECURSIVE getQuote AS ( \
51+getPostQ oTe te = select (
52+ #posts ! #postRowId :*
53+ #posts ! #postRowAuthorId :*
38− \SELECT * FROM \"quoteElements\" quote WHERE \"rowElementId\" = $1 \
54+ -- #rowElementId :*
39− \UNION ALL \
55+ #postElements ! #rowElementOrd :*
40− \SELECT newQuote.* FROM \"quoteElements\" newQuote \
56+ #postElements ! #rowElementMarkdown :*
41− \INNER JOIN getQuote q ON q.\"rowElementQuote\" = newQuote.\"rowElementId\" \
57+ #postElements ! #rowElementLatex :*
42− \) \
58+ #postElements ! #rowElementImage :*
43− \SELECT * FROM getQuote"
59+ #postElements ! #rowElementQuote :*
60+ #postElements ! #rowElementAttachment)
61+ (oTe $ postViewT te)
44
62
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+
45−getQuoteQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG PostQuoteRow)
75+-- getQuoteQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG PostQuoteRow)
46−getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1)
76+-- getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1)
47
77
48-- getQuote :: QuoteId -> PQ Quote
78-- getQuote :: QuoteId -> PQ Quote
49-- getQuote qId = do
79-- getQuote qId = do
@@ -55,62 +85,27 @@ getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1
55getUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG User)
85getUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG User)
56getUserQ = selectStar $ from (table #users) & where_ (#userId .== param @1)
86getUserQ = selectStar $ from (table #users) & where_ (#userId .== param @1)
57
87
58−getPostRowQ :: Query Schema (TuplePG (Only PostId)) (RowPG PostRow)
88+getPostByIdQ :: Query Schema (TuplePG (Only PostId)) (RowPG PostRowResponse)
59−getPostRowQ = selectStar $ from (table #posts) & where_ (#postRowId .== param @1)
89+getPostByIdQ = getPostQ id $ 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)
66
90
67−getDraftElementsQ :: Query Schema (TuplePG (Only DraftId)) (RowPG (ElementRow Draft))
91+type Limit = Word64
68−getDraftElementsQ = selectStar $ from (table #draftElements) & where_ (#rowElementId .== param @1)
69
92
70−getPost :: PostId -> StaticPQ (Maybe Post)
93+getLastNPostsQ :: Limit -> Query Schema params (RowPG PostRowResponse)
71−getPost pId = do
94+getLastNPostsQ lim = getPostQ
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] &
95+ (limit lim . orderBy [#posts ! #postRowId & Desc]) id
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)
96
96
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+
97createPostRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only PostId))
102createPostRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only PostId))
98createPostRowQ = insertRow #posts
103createPostRowQ = insertRow #posts
99 (Default `as` #postRowId :* Set (param @1) `as` #postRowAuthorId)
104 (Default `as` #postRowId :* Set (param @1) `as` #postRowAuthorId)
100 OnConflictDoRaise
105 OnConflictDoRaise
101 (Returning $ #postRowId `as` #fromOnly)
106 (Returning $ #postRowId `as` #fromOnly)
102
107
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)) '[]
114createPostElementRowsQ = insertRow_ #postElements
109createPostElementRowsQ = insertRow_ #postElements
115 (Set (param @1) `as` #rowElementId :*
110 (Set (param @1) `as` #rowElementId :*
116 Set (param @2) `as` #rowElementOrd :*
111 Set (param @2) `as` #rowElementOrd :*
@@ -120,84 +115,38 @@ createPostElementRowsQ = insertRow_ #postElements
120 Set (param @6) `as` #rowElementQuote :*
115 Set (param @6) `as` #rowElementQuote :*
121 Set (param @7) `as` #rowElementAttachment)
116 Set (param @7) `as` #rowElementAttachment)
122
117
123−createDraft :: UserId -> [PostElement Draft] -> StaticPQ Draft
118+-- MARK: FrontEnd functions
124−createDraft uId els = transactionally_ $ do
119+
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]
120+getPostsForUser :: Word64 -> UserId -> StaticPQ (Maybe [Post])
143getPostsForUser lim uId = do
121getPostsForUser lim uId = do
144− postIds <- runQueryParams (getPostsForUserLimitingQ lim) (Only uId) >>= getRows
122+ postRows <- runQueryParams (getLastNPostsForUserQ lim) (Only uId) >>= getRows
145− catMaybes <$> traverse getPost (map fromOnly postIds)
123+ return . foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId) $ postRows
146−
124+
125+getPost :: PostId -> StaticPQ (Maybe Post)
126+getPost pId = do
127+ postRow <- runQueryParams getPostByIdQ (Only pId) >>= getRows
128+ return $ rowsToPost postRow
147
129
148−getDraft :: DraftId -> StaticPQ (Maybe Draft)
130+getLastPosts :: Word64 -> StaticPQ (Maybe [Post])
149−getDraft dId = do
131+getLastPosts n = do
150− draftRow <- runQueryParams getDraftRowQ (Only dId) >>= getRow 0
132+ postRows <- runQuery (getLastNPostsQ n) >>= getRows
151− draftRowElements <- runQueryParams getDraftElementsQ (Only dId) >>= getRows
133+ return . foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId) $ postRows
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)
203
134
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 @@
4 OverloadedLabels,
4 OverloadedLabels,
5 OverloadedStrings ,
5 OverloadedStrings ,
6 TypeApplications ,
6 TypeApplications ,
7− TypeOperators #-}
7+ TypeOperators,
8+ OverloadedStrings,
9+ KindSignatures #-}
10+
8
11
9module Data.Schema (
12module Data.Schema (
10 Schema,
13 Schema,
@@ -37,13 +40,6 @@ type Schema =
37 "quoteRowId" ::: 'Def :=> 'NotNull 'PGint8,
40 "quoteRowId" ::: 'Def :=> 'NotNull 'PGint8,
38 "quoteRowPostId" ::: 'NoDef :=> 'NotNull 'PGint8
41 "quoteRowPostId" ::: 'NoDef :=> 'NotNull 'PGint8
39 ]),
42 ]),
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− ]),
47 "postElements" ::: 'Table (
43 "postElements" ::: 'Table (
48 '[
44 '[
49 "fk_post_quote_self_id" ::: 'ForeignKey '["rowElementId"] "posts" '["postRowId"],
45 "fk_post_quote_self_id" ::: 'ForeignKey '["rowElementId"] "posts" '["postRowId"],
@@ -75,24 +71,20 @@ type Schema =
75 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
71 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
76 "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
72 "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
77 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
73 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
78− ]),
74+ -- ]),
79− "draftElements" ::: 'Table (
75+ -- "postsView" ::: 'View (RowPG PostRowResponse)
80− '[
76+ -- ('[
81− "fk_draft_quote_self_id" ::: 'ForeignKey '["rowElementId"] "drafts" '["postRowId"],
77+ -- "postRowId" ::: 'NotNull 'PGint8,
82− "fk_draft_quote_id" ::: 'ForeignKey '["rowElementQuote"] "quotes" '["quoteRowId"]
78+ -- "postRowAuthorId" ::: 'NotNull 'PGint8,
83− -- ,
84− -- "unique_post_quote" ::: 'Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"]
85− ] :=>
86− '[
87− "rowElementId" ::: 'NoDef :=> 'NotNull 'PGint8,
79+ -- "rowElementId" ::: 'NotNull 'PGint8,
88− "rowElementOrd" ::: 'NoDef :=> 'NotNull 'PGint8,
80+ -- "rowElementOrd" ::: 'NotNull 'PGint8,
89− "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,
81+ -- "rowElementMarkdown" ::: 'Null 'PGtext,
90− "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,
82+ -- "rowElementLatex" ::: 'Null 'PGtext,
91− "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
83+ -- "rowElementImage" ::: 'Null 'PGtext,
92− "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
84+ -- "rowElementQuote" ::: 'Null 'PGint8,
93− "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
85+ -- "rowElementAttachment" ::: 'Null 'PGtext
94 ])
86 ])
95−
87+
96 ]
88 ]
97
89
98
90
@@ -115,12 +107,6 @@ createTables = createTable #users (
115 ) (
107 ) (
116 primaryKey #quoteRowId `as` #pk_post_quotes :*
108 primaryKey #quoteRowId `as` #pk_post_quotes :*
117 foreignKey #quoteRowPostId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_post_id
109 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
124 ) >>> createTable #postElements (
110 ) >>> createTable #postElements (
125 notNullable int8 `as` #rowElementId :*
111 notNullable int8 `as` #rowElementId :*
126 notNullable int8 `as` #rowElementOrd :*
112 notNullable int8 `as` #rowElementOrd :*
@@ -143,18 +129,21 @@ createTables = createTable #users (
143 ) (
129 ) (
144 foreignKey #rowElementId #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quotes_quote_self_id :*
130 foreignKey #rowElementId #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quotes_quote_self_id :*
145 foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_quote_id
131 foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_quote_id
146− ) >>> createTable #draftElements (
132+ -- ) >>> createView #postsView (select (
133+ -- #posts ! #postRowId :*
134+ -- #posts ! #postRowAuthorId :*
147− notNullable int8 `as` #rowElementId :*
135+ -- -- #rowElementId :*
148− notNullable int8 `as` #rowElementOrd :*
136+ -- #postElements ! #rowElementOrd :*
149− nullable text `as` #rowElementMarkdown :*
137+ -- #postElements ! #rowElementMarkdown :*
150− nullable text `as` #rowElementLatex :*
138+ -- #postElements ! #rowElementLatex :*
151− nullable text `as` #rowElementImage :*
139+ -- #postElements ! #rowElementImage :*
152− nullable int8 `as` #rowElementQuote :*
140+ -- #postElements ! #rowElementQuote :*
153− nullable text `as` #rowElementAttachment
141+ -- #postElements ! #rowElementAttachment
154− ) (
142+ -- ) (
155− foreignKey #rowElementId #drafts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_draft_quote_self_id :*
143+ -- from ((table #posts) &
156− foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_draft_quote_id
144+ -- (innerJoin (table #postElements)
145+ -- (#posts ! #postRowId .== #postElements ! #rowElementId))))
157− )
146+ )
158-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])
147-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])
159-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $
148-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $
160-- ((ifThenElse (isNull #rowElementOrd) 1 0) +
149-- ((ifThenElse (isNull #rowElementOrd) 1 0) +
denis/src/Server/API.hs+2−5
@@ -21,7 +21,6 @@ import Servant.Server
21import Data.Connection
21import Data.Connection
22import Data.Query
22import Data.Query
23import Server.App
23import Server.App
24−import Server.API.Draft
25import Server.API.Posts
24import Server.API.Posts
26import Server.Logger
25import Server.Logger
27import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))
26import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))
@@ -42,8 +41,7 @@ type API =
42 "authenticate" :> AuthenticationHandler :<|>
41 "authenticate" :> AuthenticationHandler :<|>
43 Authentication :> (
42 Authentication :> (
44 "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>
43 "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>
45− "posts" :> PostApi :<|>
44+ "posts" :> PostApi
46− "drafts" :> DraftApi
47 )
45 )
48
46
49serverProxy :: Proxy API
47serverProxy :: Proxy API
@@ -54,8 +52,7 @@ mkServerAPI l =
54 l :<|>
52 l :<|>
55 authenticate :<|> (\uId ->
53 authenticate :<|> (\uId ->
56 mapM (runQnotFound . getUser) :<|>
54 mapM (runQnotFound . getUser) :<|>
57− postApi uId :<|>
55+ postApi uId
58− draftApi uId
59 )
56 )
60
57
61-- getPostsS :: [UserId] -> App [User]
58-- 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
44
44
45type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] [P.Post] :<|>
45type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] [P.Post] :<|>
46 "last" :> ReqBody '[JSON] Word64 :> Post '[JSON] [P.Post] :<|>
46 "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
48
49
49maybeNotFound :: App (Maybe a) -> App a
50maybeNotFound :: App (Maybe a) -> App a
50maybeNotFound = (>>= (\t -> case t of
51maybeNotFound = (>>= (\t -> case t of
@@ -53,13 +54,16 @@ maybeNotFound = (>>= (\t -> case t of
53
54
54
55
55postApi :: UserId -> ServerT PostApi App
56postApi :: UserId -> ServerT PostApi App
56−postApi uId = getPosts :<|> lastPosts :<|> getPostsForUserApi
57+postApi uId = getPosts :<|> lastPosts :<|> getPostsForUserApi :<|> publishPostApi uId
57
58
58getPosts :: [P.PostId] -> App [P.Post]
59getPosts :: [P.PostId] -> App [P.Post]
59getPosts = mapM (maybeNotFound . runQnotFound . getPost)
60getPosts = mapM (maybeNotFound . runQnotFound . getPost)
60
61
61lastPosts :: Word64 -> App [P.Post]
62lastPosts :: Word64 -> App [P.Post]
62−lastPosts = runQnotFound . getLastPosts
63+lastPosts = maybeNotFound . runQnotFound . getLastPosts
63
64
64getPostsForUserApi :: UserPostsRequest -> App [P.Post]
65getPostsForUserApi :: 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:
37# Dependency packages to be pulled from upstream that are not in the resolver
37# Dependency packages to be pulled from upstream that are not in the resolver
38# using the same syntax as the packages field.
38# using the same syntax as the packages field.
39# (e.g., acme-missiles-0.3)
39# (e.g., acme-missiles-0.3)
40−extra-deps:
40+# extra-deps:
41−- servant-options-0.1.0.0
41+# - servant-options-0.1.0.0
42
42
43
43
44# Override default flag values for local packages and extra-deps
44# Override default flag values for local packages and extra-deps