git.iko.soy/denis
on master help sign in
Initial code commit

Resolved #3

commitc50189157d38bb7f8309cc63971750c216b023a6 authoriko <ilyakooo0@gmail.com> dateSat 23 Feb 2019, 18:40 (8 years ago) parentf4297fc
25 files changed+1417
compare with master
unifiedsplit
.gitignore+2 denis/.gitignore+3 denis/ChangeLog.md+3 denis/LICENSE+30 denis/README.md+1 denis/Setup.hs+2 denis/app/Main.hs+20 denis/docs/Docs.hs+59 denis/package.yaml+86 denis/src/Data/Connection.hs+38 denis/src/Data/Post.hs+99 denis/src/Data/PostElement.hs+124 denis/src/Data/Query.hs+208 denis/src/Data/RowConvertable.hs+28 denis/src/Data/Schema.hs+168 denis/src/Data/User.hs+38 denis/src/Server/API.hs+55 denis/src/Server/API/Draft.hs+64 denis/src/Server/API/Posts.hs+60 denis/src/Server/App.hs+30 denis/src/Server/Auth.hs+90 denis/src/Server/Error.hs+15 denis/src/Server/Server.hs+64 denis/stack.yaml+64 stack.yaml+66
.gitignore+2
@@ -20,3 +20,5 @@ cabal.project.local
2020cabal.project.local~
2121.HTF/
2222.ghc.environment.*
23+/backup/
24+.DS_Store
denis/.gitignorenew file+3
@@ -0,0 +1,3 @@
1+.stack-work/
2+denis.cabal
3+*~
denis/ChangeLog.mdnew file+3
@@ -0,0 +1,3 @@
1+# Changelog for denis
2+
3+## Unreleased changes
denis/LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright Author name here (c) 2019
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Author name here nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
denis/README.mdnew file+1
@@ -0,0 +1 @@
1+# denis
denis/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
denis/app/Main.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators,
8+ OverloadedStrings #-}
9+
10+module Main where
11+
12+import Data.Schema
13+import Squeal.PostgreSQL.Definition
14+import Squeal.PostgreSQL.Render
15+import Squeal.PostgreSQL.Schema
16+import Squeal.PostgreSQL.Expression
17+import Server.Server
18+
19+main :: IO ()
20+main = runServer
denis/docs/Docs.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE DataKinds,
2+ TypeOperators,
3+ OverloadedStrings,
4+ ScopedTypeVariables,
5+ FlexibleInstances #-}
6+
7+import Server.API
8+import Servant.Docs
9+import Servant.API
10+import Data.Post
11+import qualified Data.Text as T
12+import Servant.Server
13+import Servant
14+import Server.Auth
15+import Control.Lens
16+import Data.Aeson
17+import Data.PostElement
18+import Data.Proxy
19+import Data.User
20+import Data.Int (Int64)
21+import Data.Word (Word64)
22+import Server.API.Posts
23+import Server.API.Draft
24+
25+main = writeFile "docs.md" . markdown . docs . pretty $ serverProxy
26+
27+instance ToSample AuthenticationCredits where
28+ toSamples _ = samples $ map AuthenticationCredits [56, 103, 8]
29+
30+instance ToSample Char where
31+ toSamples _ = singleSample $ 'c'
32+
33+instance HasDocs api => HasDocs ((AuthProtect "basicAuth") :> api) where
34+ docsFor Proxy (endpoint, action) =
35+ docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["This method requires cookies set in the `POST /authenticate` method.\n\nReturns error `401 Unauthorized` if the cookies are invalid or don't premit access to the requested data."]])
36+
37+instance ToSample (PostData a) where
38+ toSamples _ = samples $ [PostData 8 17] <*> (map snd $ toSamples Proxy)
39+
40+instance ToSample (PostElement p) where
41+ toSamples _ = samples [
42+ Markdown "# This is a markdown title\nThis is body.",
43+ Markdown "## This is a subtitle\n_hello._"
44+ ]
45+
46+instance ToSample Int64 where
47+ toSamples _ = samples [1, 7, 2, 19]
48+
49+instance ToSample Word64 where
50+ toSamples _ = samples [1, 7, 2, 19]
51+
52+instance ToSample User where
53+ toSamples _ = samples [User 8 "Vasya" "Pupkin", User 69 "Seva" "Leonidov"]
54+
55+instance ToSample UserPostsRequest where
56+ toSamples _ = samples [UserPostsRequest 8 10, UserPostsRequest 42 20]
57+
58+instance ToSample DraftUpdate where
59+ toSamples _ = samples $ [DraftUpdate 8] <*> (map snd $ toSamples Proxy)
denis/package.yamlnew file+86
@@ -0,0 +1,86 @@
1+name: denis
2+version: 0.1.0.0
3+github: "githubuser/denis"
4+license: BSD3
5+author: "Author name here"
6+maintainer: "example@example.com"
7+copyright: "2019 Author name here"
8+
9+extra-source-files:
10+- README.md
11+- ChangeLog.md
12+
13+# Metadata used when publishing your package
14+# synopsis: Short description of your package
15+# category: Web
16+
17+# To avoid duplicated efforts in documentation and dealing with the
18+# complications of embedding Haddock markup inside cabal files, it is
19+# common to point users to the README.md file.
20+description: Please see the README on GitHub at <https://github.com/githubuser/denis#readme>
21+
22+dependencies:
23+- base >= 4.7 && < 5
24+- servant-server
25+- servant
26+- warp
27+- text
28+- aeson
29+- bytestring
30+- http-client
31+- http-client-tls
32+- stm
33+- servant-websockets
34+- websockets
35+- squeal-postgresql
36+- transformers-base
37+- generics-sop
38+- containers
39+- mtl
40+- binary
41+- wai
42+- cookie
43+- time
44+- http-types
45+- mmorph
46+- servant-docs
47+
48+- lens
49+
50+- wai-cors
51+
52+
53+
54+library:
55+ source-dirs: src
56+ ghc-options:
57+ - -Wall
58+ - -Wincomplete-uni-patterns
59+ - -Wincomplete-record-updates
60+ - -Wpartial-fields
61+ - -Werror=missing-home-modules
62+ - -Wmissing-home-modules
63+ - -Widentities
64+ - -Wredundant-constraints
65+ - -Wmissing-export-lists
66+
67+
68+executables:
69+ denis-exe:
70+ main: Main.hs
71+ source-dirs: app
72+ ghc-options:
73+ - -threaded
74+ - -rtsopts
75+ - -with-rtsopts=-N
76+ dependencies:
77+ - denis
78+ denis-docs:
79+ main: Docs.hs
80+ source-dirs: docs
81+ ghc-options:
82+ - -threaded
83+ - -rtsopts
84+ - -with-rtsopts=-N
85+ dependencies:
86+ - denis
denis/src/Data/Connection.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators #-}
8+
9+module Data.Connection (
10+ Connection,
11+ StaticPQ,
12+ runQ,
13+ runQ',
14+ runQnotFound
15+) where
16+
17+import Squeal.PostgreSQL
18+import Squeal.PostgreSQL.PQ
19+import Squeal.PostgreSQL.Pool
20+import qualified Generics.SOP as SOP
21+import Data.Schema
22+import Server.App
23+import Control.Monad.Base
24+import Control.Monad.Reader
25+import Servant.Server
26+import Control.Monad.Error
27+import Servant.Server
28+
29+type StaticPQ = PoolPQ Schema Handler
30+
31+
32+runQ :: ServantErr -> StaticPQ a -> App a
33+runQ err req = handleSqueal (const $ throwError err) $ asks getPool >>= lift . runPoolPQ req
34+
35+runQ' :: DBConnection -> ServantErr -> StaticPQ a -> Handler a
36+runQ' conn err req = handleSqueal (const $ throwError err) $ runPoolPQ req conn
37+
38+runQnotFound = runQ err404
denis/src/Data/Post.hsnew file+99
@@ -0,0 +1,99 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators,
8+ OverloadedStrings,
9+ KindSignatures #-}
10+
11+module Data.Post (
12+ Post,
13+ postId,
14+ postAuthorId,
15+ postBody,
16+ PostElement(..),
17+ PostQuote(..),
18+ PostRow,
19+ PostQuoteRow,
20+ ElementRow,
21+ postToRow,
22+ postToElementRows,
23+ rowsToPost,
24+ PostId,
25+ QuoteId,
26+ Draft,
27+ DraftId,
28+ mkDraft,
29+ fromDraft,
30+
31+ -- for docs only
32+ PostData(..),
33+ PostType(..)
34+) where
35+
36+import Data.Int (Int64)
37+-- import Squeal.PostgreSQL
38+-- import Squeal.PostgreSQL.Render
39+-- import qualified Squeal.PostgreSQL.PQ as P
40+import qualified Generics.SOP as SOP
41+import qualified GHC.Generics as GHC
42+-- import Squeal.PostgreSQL.Schema
43+import Data.Aeson
44+import qualified Data.Map.Lazy as M
45+
46+import Data.PostElement
47+-- import Data.RowConvertable
48+
49+-- MARK: Actual type
50+
51+type PostId = Int64
52+type QuoteId = Int64
53+type DraftId = Int64
54+
55+data PostType = Draft | NonDraft
56+
57+data PostData (p :: PostType) = PostData {
58+ postId :: Int64,
59+ postAuthorId :: Int64,
60+ postBody :: [PostElement (PostData p)]
61+}
62+
63+type Post = (PostData 'NonDraft)
64+type Draft = (PostData 'Draft)
65+
66+mkDraft :: DraftId -> Int64 -> [PostElement Draft] -> Draft
67+mkDraft = PostData
68+
69+instance ToJSON (PostData p) where
70+ toJSON (PostData pId aId pb) = object [
71+ "id" .= pId,
72+ "authorId" .= aId,
73+ "body" .= pb ]
74+
75+
76+-- MARK: Rows
77+
78+data PostRow = PostRow {
79+ postRowId :: Int64,
80+ postRowAuthorId :: Int64
81+} deriving (GHC.Generic)
82+
83+instance SOP.Generic PostRow
84+instance SOP.HasDatatypeInfo PostRow
85+
86+postToRow :: Post -> PostRow
87+postToRow (PostData pId aId _) = PostRow pId aId
88+
89+postToElementRows :: PostData p -> [ElementRow (PostData p)]
90+postToElementRows (PostData pId _ pb) = elementsToRows pId pb
91+
92+rowsToPost :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostRow -> [ElementRow (PostData p)] -> Maybe (PostData p)
93+rowsToPost erqs pqrs (PostRow pId aId) elementRows = PostData pId aId <$> rowsToElements erqs pqrs elementRows
94+
95+fromDraft :: PostId -> ElementRow Draft -> ElementRow Post
96+fromDraft pId (ElementRow _ b c d e f g) = ElementRow pId b c d e f g
97+
98+-- tupleFirst :: (a -> b) -> a -> (b, a)
99+-- tupleFirst f a = (f a, a)
denis/src/Data/PostElement.hsnew file+124
@@ -0,0 +1,124 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators,
8+ OverloadedStrings #-}
9+
10+
11+module Data.PostElement (
12+ PostElement(..),
13+ ElementRow(..),
14+ elementsToRows,
15+ PostQuoteRow(..),
16+ PostQuote(..),
17+ rowsToElements
18+) where
19+
20+import Data.Int (Int64)
21+import qualified Generics.SOP as SOP
22+import qualified GHC.Generics as GHC
23+import Data.Text (Text)
24+import Data.Aeson
25+import qualified Data.Map.Lazy as M
26+import Data.List (sortBy)
27+import Data.Function (on)
28+import Control.Applicative ((<|>))
29+
30+
31+-- MARK: PostElement
32+
33+data PostElement a = Markdown Text
34+ | Latex Text
35+ | Image Text
36+ | Quote PostQuote
37+ | Attachment Text
38+
39+
40+data ElementRow a = ElementRow {
41+ rowElementId :: Int64, -- the source id
42+ rowElementOrd :: Int64,
43+ rowElementMarkdown :: Maybe Text,
44+ rowElementLatex :: Maybe Text,
45+ rowElementImage :: Maybe Text,
46+ rowElementQuote :: Maybe Int64,
47+ rowElementAttachment :: Maybe Text
48+} deriving (GHC.Generic)
49+
50+instance SOP.Generic (ElementRow a)
51+instance SOP.HasDatatypeInfo (ElementRow a)
52+
53+instance ToJSON (PostElement t) where
54+ toJSON (Markdown m) = object ["markdown" .= m]
55+ toJSON (Latex l) = object ["latex" .= l]
56+ toJSON (Image i) = object ["image" .= i]
57+ toJSON (Quote q) = object ["quote" .= q]
58+ toJSON (Attachment a) = object ["attachment" .= a]
59+
60+instance FromJSON (PostElement t) where
61+ parseJSON = withObject "post element" $ \e ->
62+ Markdown <$> e .: "markdown" <|>
63+ Latex <$> e .: "latex" <|>
64+ Image <$> e .: "image" <|>
65+ -- Quote <$> e .: "quote" <|>
66+ Attachment <$> e .: "attachment"
67+
68+
69+-- MARK: PostElementRows
70+
71+-- TODO: After embeding id into quote
72+rowsToElements :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> [ElementRow p] -> Maybe [PostElement p]
73+rowsToElements erqs pqrs = traverse elementRowToElement . sortBy (compare `on` rowElementOrd)
74+ where
75+ elementRowToElement :: ElementRow a -> Maybe (PostElement a)
76+ elementRowToElement (ElementRow _ _ (Just m) Nothing Nothing Nothing Nothing) = Just $ Markdown m
77+ elementRowToElement (ElementRow _ _ Nothing (Just l) Nothing Nothing Nothing) = Just $ Latex l
78+ elementRowToElement (ElementRow _ _ Nothing Nothing (Just i) Nothing Nothing) = Just $ Image i
79+ -- elementRowToElement (ElementRow _ _ Nothing Nothing Nothing (Just q) Nothing) =
80+ -- fmap Quote $ M.lookup q pqrs >>= rowsToQuote erqs pqrs
81+ elementRowToElement (ElementRow _ _ Nothing Nothing Nothing Nothing (Just a)) = Just $ Attachment a
82+ elementRowToElement _ = Nothing
83+
84+elementsToRows :: Int64 -> [PostElement p] -> [ElementRow p]
85+elementsToRows pId pb = map (uncurry finish) $ flip zip pb $ ElementRow pId <$> [0..]
86+ where finish :: (Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int64 -> Maybe Text -> ElementRow p) -> PostElement p -> ElementRow p
87+ finish f pe = case pe of
88+ Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
89+ Latex l -> f Nothing (Just l) Nothing Nothing Nothing
90+ Image i -> f Nothing Nothing (Just i) Nothing Nothing
91+ Quote q -> f Nothing Nothing Nothing (Just $ quoteId q) Nothing
92+ Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
93+
94+
95+-- MARK: Quote
96+
97+data PostQuote = PostQuote {
98+ quoteId :: Int64,
99+ quoteBody :: [PostElement PostQuote],
100+ quotePostId :: Int64
101+}
102+
103+instance ToJSON PostQuote where
104+ toJSON (PostQuote qId pb pId) = object [
105+ "id" .= qId,
106+ "postId" .= pId,
107+ "quoteBody" .= pb ]
108+
109+
110+-- MARK: PostQuoteRow
111+
112+data PostQuoteRow = PostQuoteRow {
113+ quoteRowId :: Int64,
114+ quoteRowPostId :: Int64
115+} deriving (GHC.Generic)
116+
117+instance SOP.Generic PostQuoteRow
118+instance SOP.HasDatatypeInfo PostQuoteRow
119+
120+rowsToQuote :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostQuoteRow -> Maybe PostQuote
121+rowsToQuote erqs pqrs (PostQuoteRow qId pId) = do
122+ elementRows <- M.lookup qId erqs
123+ elements <- rowsToElements erqs pqrs elementRows
124+ return $ PostQuote qId elements pId
denis/src/Data/Query.hsnew file+208
@@ -0,0 +1,208 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators #-}
8+
9+module Data.Query (
10+ Schema,
11+ createTables,
12+ getPost,
13+ getUser,
14+ createDraft,
15+ updateDraft,
16+ publishDraft,
17+ getDrafts,
18+ getLastPosts,
19+ getPostsForUser
20+) where
21+
22+import Squeal.PostgreSQL
23+import Squeal.PostgreSQL.Expression
24+import Squeal.PostgreSQL.Schema
25+import Data.User
26+import Data.Post
27+import Data.Schema
28+import Data.List
29+import Data.Function (on)
30+import qualified Data.Map.Lazy as M
31+import Server.App
32+import Data.Connection
33+import Data.PostElement
34+import Control.Monad.Base
35+import Control.Monad ((<$!>))
36+import qualified Servant as S
37+import Control.Monad.Morph
38+import Data.Maybe
39+import Data.Word (Word64)
40+
41+
42+getQuoteRowsQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG (ElementRow Post))
43+getQuoteRowsQ = UnsafeQuery "WITH RECURSIVE getQuote AS ( \
44+ \SELECT * FROM \"quoteElements\" quote WHERE \"rowElementId\" = $1 \
45+ \UNION ALL \
46+ \SELECT newQuote.* FROM \"quoteElements\" newQuote \
47+ \INNER JOIN getQuote q ON q.\"rowElementQuote\" = newQuote.\"rowElementId\" \
48+ \) \
49+ \SELECT * FROM getQuote"
50+
51+getQuoteQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG PostQuoteRow)
52+getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1)
53+
54+-- getQuote :: QuoteId -> PQ Quote
55+-- getQuote qId = do
56+-- rows' <- runQuery getQuoteQ (Only qId) >>= getRows
57+-- qRow <- runQuery getQuoteQ (Only qId) >>= getRow 0
58+-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
59+-- return $ M.lookup qId rows >>= rowsToQuote rows
60+
61+getUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG User)
62+getUserQ = selectStar $ from (table #users) & where_ (#userId .== param @1)
63+
64+getPostRowQ :: Query Schema (TuplePG (Only PostId)) (RowPG PostRow)
65+getPostRowQ = selectStar $ from (table #posts) & where_ (#postRowId .== param @1)
66+
67+getDraftRowQ :: Query Schema (TuplePG (Only DraftId)) (RowPG PostRow)
68+getDraftRowQ = selectStar $ from (table #drafts) & where_ (#postRowId .== param @1)
69+
70+getPostElementsQ :: Query Schema (TuplePG (Only PostId)) (RowPG (ElementRow Post))
71+getPostElementsQ = selectStar $ from (table #postElements) & where_ (#rowElementId .== param @1)
72+
73+getDraftElementsQ :: Query Schema (TuplePG (Only DraftId)) (RowPG (ElementRow Draft))
74+getDraftElementsQ = selectStar $ from (table #draftElements) & where_ (#rowElementId .== param @1)
75+
76+getPost :: PostId -> StaticPQ (Maybe Post)
77+getPost pId = do
78+ postRow <- runQueryParams getPostRowQ (Only pId) >>= getRow 0
79+ postRowElements <- runQueryParams getPostElementsQ (Only pId) >>= getRows
80+ return $ rowsToPost M.empty M.empty postRow postRowElements
81+
82+getLastPostRowsQ :: Word64 -> Query Schema '[] (RowPG (Only PostId))
83+getLastPostRowsQ n = select (#postRowId `as` #fromOnly) $
84+ (from $ table #posts) &
85+ orderBy [#postRowId & Desc] &
86+ limit n
87+
88+getLastPosts :: Word64 -> StaticPQ [Post]
89+getLastPosts n = do
90+ postIds <- runQuery (getLastPostRowsQ n) >>= getRows
91+ catMaybes <$> traverse getPost (map fromOnly postIds)
92+
93+getUser :: UserId -> StaticPQ User
94+getUser uId = runQueryParams getUserQ (Only uId) >>= getRow 0
95+
96+
97+createDraftRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
98+createDraftRowQ = insertRow #drafts
99+ (Default `as` #postRowId :* Set (param @1) `as` #postRowAuthorId)
100+ OnConflictDoRaise
101+ (Returning $ #postRowId `as` #fromOnly)
102+
103+createPostRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only PostId))
104+createPostRowQ = insertRow #posts
105+ (Default `as` #postRowId :* Set (param @1) `as` #postRowAuthorId)
106+ OnConflictDoRaise
107+ (Returning $ #postRowId `as` #fromOnly)
108+
109+createDraftElementRowsQ :: Manipulation Schema (TuplePG (ElementRow Draft)) '[]
110+createDraftElementRowsQ = insertRow_ #draftElements
111+ (Set (param @1) `as` #rowElementId :*
112+ Set (param @2) `as` #rowElementOrd :*
113+ Set (param @3) `as` #rowElementMarkdown :*
114+ Set (param @4) `as` #rowElementLatex :*
115+ Set (param @5) `as` #rowElementImage :*
116+ Set (param @6) `as` #rowElementQuote :*
117+ Set (param @7) `as` #rowElementAttachment)
118+
119+createPostElementRowsQ :: Manipulation Schema (TuplePG (ElementRow Post)) '[]
120+createPostElementRowsQ = insertRow_ #postElements
121+ (Set (param @1) `as` #rowElementId :*
122+ Set (param @2) `as` #rowElementOrd :*
123+ Set (param @3) `as` #rowElementMarkdown :*
124+ Set (param @4) `as` #rowElementLatex :*
125+ Set (param @5) `as` #rowElementImage :*
126+ Set (param @6) `as` #rowElementQuote :*
127+ Set (param @7) `as` #rowElementAttachment)
128+
129+createDraft :: UserId -> [PostElement Draft] -> StaticPQ Draft
130+createDraft uId els = transactionally_ $ do
131+ dId' <- manipulateParams createDraftRowQ (Only uId)
132+ dId <- lift $ fromOnly <$> getRow 0 dId'
133+ traversePrepared_ createDraftElementRowsQ $ elementsToRows dId els
134+ return $ mkDraft dId uId els
135+
136+getDraftsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
137+getDraftsForUserQ = select (#postRowId `as` #fromOnly) $
138+ (from $ table #drafts) &
139+ where_ (#postRowAuthorId .== param @1)
140+
141+getPostsForUserLimitingQ :: Word64 -> Query Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
142+getPostsForUserLimitingQ lim = select (#postRowId `as` #fromOnly) $
143+ (from $ table #posts) &
144+ where_ (#postRowAuthorId .== param @1) &
145+ limit lim
146+
147+getPostsForUser :: Word64 -> UserId -> StaticPQ [Post]
148+getPostsForUser lim uId = do
149+ postIds <- runQueryParams (getPostsForUserLimitingQ lim) (Only uId) >>= getRows
150+ catMaybes <$> traverse getPost (map fromOnly postIds)
151+
152+
153+getDraft :: DraftId -> StaticPQ (Maybe Draft)
154+getDraft dId = do
155+ draftRow <- runQueryParams getDraftRowQ (Only dId) >>= getRow 0
156+ draftRowElements <- runQueryParams getDraftElementsQ (Only dId) >>= getRows
157+ return $ rowsToPost M.empty M.empty draftRow draftRowElements
158+
159+getDrafts :: UserId -> StaticPQ [Draft]
160+getDrafts uId = do
161+ draftRow <- runQueryParams getDraftsForUserQ (Only uId) >>= getRows
162+ catMaybes <$> traverse getDraft (map fromOnly draftRow)
163+
164+getDraftForUserWithIdQ :: Query Schema (TuplePG (UserId, DraftId)) (RowPG PostRow)
165+getDraftForUserWithIdQ = selectStar $
166+ (from $ table #drafts) &
167+ where_ (#postRowAuthorId .== param @1 .&& #postRowId .== param @2)
168+
169+deleteElementsForIdQ :: Manipulation Schema (TuplePG (Only DraftId)) '[]
170+deleteElementsForIdQ = deleteFrom_ #draftElements (#rowElementId .== param @1)
171+
172+deleteDraftQ :: Manipulation Schema (TuplePG (Only DraftId)) '[]
173+deleteDraftQ = deleteFrom_ #drafts (#postRowId .== param @1)
174+
175+updateDraft :: UserId -> DraftId -> [PostElement Draft] -> StaticPQ ()
176+updateDraft uId dId els = transactionally_ $ do
177+ rs <- runQueryParams getDraftForUserWithIdQ (uId, dId) >>= getRows
178+ let c = length (rs :: [PostRow])
179+ if c /= 1 then
180+ lift $ S.throwError S.err404
181+ else do
182+ manipulateParams deleteElementsForIdQ (Only dId)
183+ traversePrepared_ createDraftElementRowsQ $ elementsToRows dId els
184+
185+getDraftElementRowsQ :: Query Schema (TuplePG (Only DraftId)) (RowPG (ElementRow Draft))
186+getDraftElementRowsQ = selectStar $
187+ (from $ table #draftElements) &
188+ where_ (#rowElementId .== param @1) &
189+ orderBy [#rowElementOrd & Asc]
190+
191+publishDraft :: UserId -> DraftId -> StaticPQ ()
192+publishDraft uId dId = transactionally_ $ do
193+ rs <- runQueryParams getDraftForUserWithIdQ (uId, dId) >>= getRows
194+ let c = length (rs :: [PostRow])
195+ if c /= 1 then
196+ lift $ S.throwError S.err404
197+ else do
198+ els <- runQueryParams getDraftElementRowsQ (Only dId) >>= getRows
199+ pId' <- manipulateParams createPostRowQ (Only uId)
200+ pId <- lift $ fromOnly <$> getRow 0 pId'
201+ traversePrepared_ createPostElementRowsQ $ map (fromDraft pId) els
202+ manipulateParams deleteDraftQ (Only dId)
203+ return ()
204+
205+
206+-- tupleFirst :: (a -> b) -> a -> (b, a)
207+-- tupleFirst f x = (f x, x)
208+
denis/src/Data/RowConvertable.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators #-}
8+
9+
10+module Data.RowConvertable (
11+ -- RowConvertable(..)
12+ ) where
13+
14+import Data.Int (Int64)
15+import Squeal.PostgreSQL
16+import Squeal.PostgreSQL.Schema
17+import GHC.TypeLits (Symbol)
18+import Squeal.PostgreSQL.Render
19+import qualified Squeal.PostgreSQL.PQ as P
20+import qualified Generics.SOP as SOP
21+import qualified GHC.Generics as GHC
22+import Data.Text (Text)
23+
24+
25+-- class RowConvertable t r where
26+-- convertToRow :: a -> RowPG r
27+-- fromRow :: TuplePG r -> a
28+
denis/src/Data/Schema.hsnew file+168
@@ -0,0 +1,168 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators #-}
8+
9+module Data.Schema (
10+ Schema,
11+ createTables
12+) where
13+
14+import Squeal.PostgreSQL
15+import Squeal.PostgreSQL.Expression
16+import Squeal.PostgreSQL.Schema
17+import Data.User
18+import Data.Post
19+
20+type Schema =
21+ '[
22+ "users" ::: 'Table ( '[
23+ "pk_users" ::: 'PrimaryKey '["userId"]] :=>
24+ '[
25+ "userId" ::: 'Def :=> 'NotNull 'PGint8,
26+ "firstName" ::: 'NoDef :=> 'NotNull 'PGtext,
27+ "secondName" ::: 'NoDef :=> 'NotNull 'PGtext
28+ ]),
29+ "posts" ::: 'Table ( '[
30+ "pk_posts" ::: 'PrimaryKey '["postRowId"],
31+ "fk_author_id" ::: 'ForeignKey '["postRowAuthorId"] "users" '["userId"]] :=>
32+ '[
33+ "postRowId" ::: 'Def :=> 'NotNull 'PGint8,
34+ "postRowAuthorId" ::: 'NoDef :=> 'NotNull 'PGint8
35+ ]),
36+ "quotes" ::: 'Table (
37+ '[
38+ "pk_post_quotes" ::: 'PrimaryKey '["quoteRowId"],
39+ "fk_quote_post_id" ::: 'ForeignKey '["quoteRowPostId"] "posts" '["postRowId"] ] :=>
40+ '[
41+ "quoteRowId" ::: 'Def :=> 'NotNull 'PGint8,
42+ "quoteRowPostId" ::: 'NoDef :=> 'NotNull 'PGint8
43+ ]),
44+ "drafts" ::: 'Table ( '[
45+ "pk_drafts" ::: 'PrimaryKey '["postRowId"],
46+ "fk_draft_author_id" ::: 'ForeignKey '["postRowAuthorId"] "users" '["userId"]] :=>
47+ '[
48+ "postRowId" ::: 'Def :=> 'NotNull 'PGint8,
49+ "postRowAuthorId" ::: 'NoDef :=> 'NotNull 'PGint8
50+ ]),
51+ "postElements" ::: 'Table (
52+ '[
53+ "fk_post_quote_self_id" ::: 'ForeignKey '["rowElementId"] "posts" '["postRowId"],
54+ "fk_post_quote_id" ::: 'ForeignKey '["rowElementQuote"] "quotes" '["quoteRowId"]
55+ -- ,
56+ -- "unique_post_quote" ::: 'Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"]
57+ ] :=>
58+ '[
59+ "rowElementId" ::: 'NoDef :=> 'NotNull 'PGint8,
60+ "rowElementOrd" ::: 'NoDef :=> 'NotNull 'PGint8,
61+ "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,
62+ "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,
63+ "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
64+ "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
65+ "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
66+ ]),
67+ "quoteElements" ::: 'Table (
68+ '[
69+ "fk_quotes_quote_self_id" ::: 'ForeignKey '["rowElementId"] "quotes" '["quoteRowId"],
70+ "fk_quote_quote_id" ::: 'ForeignKey '["rowElementQuote"] "quotes" '["quoteRowId"]
71+ -- ,
72+ -- "unique_quote_quote" ::: 'Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"]
73+ ] :=>
74+ '[
75+ "rowElementId" ::: 'NoDef :=> 'NotNull 'PGint8,
76+ "rowElementOrd" ::: 'NoDef :=> 'NotNull 'PGint8,
77+ "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,
78+ "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,
79+ "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
80+ "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
81+ "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
82+ ]),
83+ "draftElements" ::: 'Table (
84+ '[
85+ "fk_draft_quote_self_id" ::: 'ForeignKey '["rowElementId"] "drafts" '["postRowId"],
86+ "fk_draft_quote_id" ::: 'ForeignKey '["rowElementQuote"] "quotes" '["quoteRowId"]
87+ -- ,
88+ -- "unique_post_quote" ::: 'Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"]
89+ ] :=>
90+ '[
91+ "rowElementId" ::: 'NoDef :=> 'NotNull 'PGint8,
92+ "rowElementOrd" ::: 'NoDef :=> 'NotNull 'PGint8,
93+ "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,
94+ "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,
95+ "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
96+ "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
97+ "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
98+ ])
99+
100+ ]
101+
102+
103+createTables :: Definition '[] Schema
104+createTables = createTable #users (
105+ serial8 `as` #userId :*
106+ notNullable text `as` #firstName :*
107+ notNullable text `as` #secondName
108+ ) (
109+ primaryKey #userId `as` #pk_users
110+ ) >>> createTable #posts (
111+ serial8 `as` #postRowId :*
112+ notNullable int8 `as` #postRowAuthorId
113+ ) (
114+ primaryKey #postRowId `as` #pk_posts :*
115+ foreignKey #postRowAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_author_id
116+ ) >>> createTable #quotes (
117+ serial8 `as` #quoteRowId :*
118+ notNullable int8 `as` #quoteRowPostId
119+ ) (
120+ primaryKey #quoteRowId `as` #pk_post_quotes :*
121+ foreignKey #quoteRowPostId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_post_id
122+ ) >>> createTable #drafts (
123+ serial8 `as` #postRowId :*
124+ notNullable int8 `as` #postRowAuthorId
125+ ) (
126+ primaryKey #postRowId `as` #pk_drafts :*
127+ foreignKey #postRowAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_draft_author_id
128+ ) >>> createTable #postElements (
129+ notNullable int8 `as` #rowElementId :*
130+ notNullable int8 `as` #rowElementOrd :*
131+ nullable text `as` #rowElementMarkdown :*
132+ nullable text `as` #rowElementLatex :*
133+ nullable text `as` #rowElementImage :*
134+ nullable int8 `as` #rowElementQuote :*
135+ nullable text `as` #rowElementAttachment
136+ ) (
137+ foreignKey #rowElementId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_post_quote_self_id :*
138+ foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_post_quote_id
139+ ) >>> createTable #quoteElements (
140+ notNullable int8 `as` #rowElementId :*
141+ notNullable int8 `as` #rowElementOrd :*
142+ nullable text `as` #rowElementMarkdown :*
143+ nullable text `as` #rowElementLatex :*
144+ nullable text `as` #rowElementImage :*
145+ nullable int8 `as` #rowElementQuote :*
146+ nullable text `as` #rowElementAttachment
147+ ) (
148+ foreignKey #rowElementId #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quotes_quote_self_id :*
149+ foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_quote_id
150+ ) >>> createTable #draftElements (
151+ notNullable int8 `as` #rowElementId :*
152+ notNullable int8 `as` #rowElementOrd :*
153+ nullable text `as` #rowElementMarkdown :*
154+ nullable text `as` #rowElementLatex :*
155+ nullable text `as` #rowElementImage :*
156+ nullable int8 `as` #rowElementQuote :*
157+ nullable text `as` #rowElementAttachment
158+ ) (
159+ foreignKey #rowElementId #drafts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_draft_quote_self_id :*
160+ foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_draft_quote_id
161+ )
162+-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])
163+-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $
164+-- ((ifThenElse (isNull #rowElementOrd) 1 0) +
165+-- (ifThenElse (isNull #rowElementOrd) 1 0) +
166+-- (ifThenElse (isNull #rowElementOrd) 1 0) +
167+-- (ifThenElse (isNull #rowElementOrd) 1 0) +
168+-- (ifThenElse (isNull #rowElementOrd) 1 0)) .== 0
denis/src/Data/User.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators,
8+ OverloadedStrings #-}
9+
10+module Data.User (
11+ User(..),
12+ UserId
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.Text (Text)
19+import Data.Aeson
20+
21+type UserId = Int64
22+
23+data User = User {
24+ userId :: UserId,
25+ firstName :: Text,
26+ secondName :: Text
27+} deriving (GHC.Generic)
28+
29+instance SOP.Generic User
30+
31+instance SOP.HasDatatypeInfo User
32+
33+instance ToJSON User where
34+ toJSON (User uId fName sName) = object [
35+ "id" .= uId,
36+ "firstName" .= fName,
37+ "secondName" .= sName
38+ ]
denis/src/Server/API.hsnew file+55
@@ -0,0 +1,55 @@
1+{-# LANGUAGE DataKinds,
2+ TypeOperators,
3+ OverloadedStrings,
4+ ScopedTypeVariables #-}
5+
6+module Server.API (
7+ API,
8+ serverProxy,
9+ serverAPI
10+) where
11+
12+import Data.Proxy
13+import Servant.API
14+-- import Servant
15+import Servant.Server.Experimental.Auth
16+import Data.User
17+import qualified Data.Post as P
18+import Server.Auth
19+import Data.ByteString
20+import Data.Int (Int64)
21+import Servant.Server
22+import Data.Connection
23+import Data.Query
24+import Server.Auth
25+import Server.App
26+import Control.Monad.Error
27+import Server.API.Draft
28+import Server.API.Posts
29+
30+maybeNotFound :: App (Maybe a) -> App a
31+maybeNotFound = (>>= (\t -> case t of
32+ Just y -> return y
33+ Nothing -> throwError err404))
34+
35+type API = "authenticate" :> AuthenticationHandler
36+ :<|>
37+ AuthProtect "basicAuth" :> (
38+ "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>
39+ "posts" :> PostApi :<|>
40+ "drafts" :> DraftApi
41+ )
42+
43+serverProxy :: Proxy API
44+serverProxy = Proxy
45+
46+serverAPI :: ServerT API App
47+serverAPI = authenticate :<|> (\uId ->
48+ mapM (runQnotFound . getUser) :<|>
49+ postApi uId :<|>
50+ draftApi uId
51+ )
52+
53+-- getPostsS :: [UserId] -> App [User]
54+-- getPostsS = mapM getPost
55+
denis/src/Server/API/Draft.hsnew file+64
@@ -0,0 +1,64 @@
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 Data.Int (Int64)
21+import Server.App
22+import Servant.Server
23+import Data.Query
24+import Data.User
25+import Data.Connection
26+
27+data DraftUpdate = DraftUpdate {
28+ draftId :: P.DraftId,
29+ draftContent :: [P.PostElement P.Draft]
30+ } deriving Generic
31+
32+instance FromJSON DraftUpdate where
33+ parseJSON = withObject "Post update object" $ \e ->
34+ DraftUpdate <$> e .: "id" <*> e.: "body"
35+instance ToJSON DraftUpdate where
36+ toJSON (DraftUpdate dId body) = object [
37+ "id" .= dId,
38+ "body" .= body
39+ ]
40+
41+
42+type DraftApi = "create" :> ReqBody '[JSON] [P.PostElement P.Draft] :> Post '[JSON] P.DraftId :<|>
43+ "update" :> ReqBody '[JSON] DraftUpdate :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
44+ "publish" :> ReqBody '[JSON] P.DraftId :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
45+ "all" :> Post '[JSON] [DraftUpdate]
46+
47+draftApi :: UserId -> ServerT DraftApi App
48+draftApi uId =
49+ (fmap P.postId . runQnotFound . createDraft uId) :<|> updateDraftApi uId :<|>
50+ publishDraftApi uId :<|>
51+ runQnotFound (fmap (map postToDraft) $ getDrafts uId)
52+
53+updateDraftApi :: UserId -> DraftUpdate -> App NoContent
54+updateDraftApi uId (DraftUpdate dId els) = do
55+ runQnotFound $ updateDraft uId dId els
56+ return NoContent
57+
58+publishDraftApi :: UserId -> P.DraftId -> App NoContent
59+publishDraftApi uId dId = do
60+ runQnotFound $ publishDraft uId dId
61+ return NoContent
62+
63+postToDraft :: P.Draft -> DraftUpdate
64+postToDraft (P.PostData dId _ body) = DraftUpdate dId body
denis/src/Server/API/Posts.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators #-}
8+
9+module Server.API.Posts (
10+ PostApi,
11+ postApi,
12+ UserPostsRequest(..)
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 Data.Int (Int64)
21+import Server.App
22+import Servant.Server
23+import Data.Query
24+import Data.User
25+import Data.Connection
26+import Servant
27+import Data.Word (Word64)
28+
29+data UserPostsRequest = UserPostsRequest {
30+ userPostRequestId :: UserId,
31+ userPostRequestLimit :: Word64
32+}
33+
34+instance ToJSON UserPostsRequest where
35+ toJSON (UserPostsRequest uId lim) = object ["userId" .= uId, "limit" .= lim]
36+instance FromJSON UserPostsRequest where
37+ parseJSON = withObject "User posts request" $ \e ->
38+ UserPostsRequest <$> e .: "userId" <*> e.: "limit"
39+
40+type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] [P.Post] :<|>
41+ "last" :> ReqBody '[JSON] Word64 :> Post '[JSON] [P.Post] :<|>
42+ "forUser" :> ReqBody '[JSON] UserPostsRequest :> Post '[JSON] [P.Post]
43+
44+maybeNotFound :: App (Maybe a) -> App a
45+maybeNotFound = (>>= (\t -> case t of
46+ Just y -> return y
47+ Nothing -> throwError err404))
48+
49+
50+postApi :: UserId -> ServerT PostApi App
51+postApi uId = getPosts :<|> lastPosts :<|> getPostsForUserApi
52+
53+getPosts :: [P.PostId] -> App [P.Post]
54+getPosts = mapM (maybeNotFound . runQnotFound . getPost)
55+
56+lastPosts :: Word64 -> App [P.Post]
57+lastPosts = runQnotFound . getLastPosts
58+
59+getPostsForUserApi :: UserPostsRequest -> App [P.Post]
60+getPostsForUserApi (UserPostsRequest uId lim) = runQnotFound $ getPostsForUser lim uId
denis/src/Server/App.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators #-}
8+
9+module Server.App (
10+ App,
11+ DBConnection,
12+ Config(..),
13+ ask,
14+ asks
15+) where
16+
17+import Servant.Server
18+import Control.Monad.Reader
19+import Squeal.PostgreSQL.Pool
20+import Data.Schema
21+import Generics.SOP (K)
22+import Squeal.PostgreSQL.PQ (Connection)
23+
24+type App = ReaderT Config Handler
25+
26+type DBConnection = Pool (K Connection Schema)
27+
28+data Config = Config {
29+ getPool :: DBConnection
30+}
denis/src/Server/Auth.hsnew file+90
@@ -0,0 +1,90 @@
1+{-# LANGUAGE DataKinds,
2+ DeriveGeneric,
3+ FlexibleContexts,
4+ FlexibleInstances,
5+ MultiParamTypeClasses,
6+ OverloadedStrings,
7+ ScopedTypeVariables,
8+ TypeFamilies,
9+ TypeOperators,
10+ UndecidableInstances #-}
11+
12+module Server.Auth (
13+ checkToken,
14+ cookieTokenKey,
15+ genAuthServerContext,
16+ AuthenticationHandler,
17+ authenticate,
18+ contextProxy,
19+ AuthenticationCredits(..)
20+) where
21+
22+import Server.App
23+import Data.User
24+import Data.ByteString
25+import qualified Data.ByteString.Char8 as C
26+import Data.Query
27+import Data.Binary (decode)
28+import Server.Error
29+import Control.Monad.Error
30+import Text.Read (readMaybe)
31+import Squeal.PostgreSQL.PQ
32+import Data.Connection
33+import Servant.Server.Experimental.Auth
34+import Servant.API
35+import Network.Wai (Request, requestHeaders)
36+import Servant.Server
37+import Web.Cookie (parseCookies)
38+import Data.Time.Clock
39+import Data.Monoid ((<>))
40+import Data.Text
41+import Data.Proxy
42+import qualified GHC.Generics as GHC
43+import Data.Aeson
44+
45+type AuthenticationHandler = ReqBody '[JSON] AuthenticationCredits :> PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)
46+
47+data AuthenticationCredits = AuthenticationCredits {authenticationId :: UserId}
48+ deriving GHC.Generic
49+
50+instance ToJSON AuthenticationCredits
51+instance FromJSON AuthenticationCredits
52+
53+authenticate :: ServerT AuthenticationHandler App
54+authenticate (AuthenticationCredits uId) = do
55+ conn <- ask
56+ expire <- liftIO $ fmap (addUTCTime (1 * 24 * 60 * 60)) getCurrentTime -- one days
57+ tId <- fmap userId . runQ invalidToken . getUser $ uId
58+ let token = cookieTokenKeyString <> "=" <> show tId <> "; Expires=" <> show expire <> "" -- ; Secure" --; HttpOnly"
59+ return $ addHeader token NoContent
60+
61+
62+
63+checkToken :: DBConnection -> ByteString -> Handler UserId
64+checkToken conn token = do
65+ uId <- case ((readMaybe . C.unpack) token :: Maybe UserId) of
66+ Just uId -> return uId
67+ Nothing -> throwError invalidToken
68+ fmap userId . runQ' conn invalidToken . getUser $ uId
69+
70+authHandler :: DBConnection -> AuthHandler Request UserId
71+authHandler conn = mkAuthHandler handler
72+ where
73+ maybeToEither e = maybe (Left e) Right
74+ throw401 msg = throwError $ err401 { errBody = msg }
75+ handler req = either throw401 (checkToken conn) $ do
76+ cookie <- maybeToEither "Missing cookie header" $ lookup "cookie" $ requestHeaders req
77+ maybeToEither "Missing token in cookie" $ lookup cookieTokenKey $ parseCookies cookie
78+
79+cookieTokenKey :: ByteString
80+cookieTokenKey = "servant-auth-cookie"
81+
82+cookieTokenKeyString = C.unpack cookieTokenKey
83+
84+type instance AuthServerData (AuthProtect "basicAuth") = UserId
85+
86+genAuthServerContext :: DBConnection -> Context (AuthHandler Request UserId ': '[])
87+genAuthServerContext conn = authHandler conn :. EmptyContext
88+
89+contextProxy :: Proxy '[AuthHandler Request UserId]
90+contextProxy = Proxy
denis/src/Server/Error.hsnew file+15
@@ -0,0 +1,15 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Server.Error (
4+ invalidToken
5+) where
6+
7+import Servant.Server
8+
9+invalidToken :: ServantErr
10+invalidToken = ServantErr {
11+ errHTTPCode = 401,
12+ errReasonPhrase = "Invalid Token",
13+ errBody = "The supplied token is invalid",
14+ errHeaders = []
15+}
denis/src/Server/Server.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Server.Server (
4+ runServer
5+) where
6+
7+import Server.API
8+import Server.Auth
9+import Server.App
10+
11+import Servant.Server
12+import Servant.API
13+import System.Environment
14+import qualified Data.ByteString.Char8 as B
15+import Squeal.PostgreSQL.Pool
16+import Data.Maybe
17+import Control.Monad.Reader
18+import Network.Wai.Handler.Warp
19+import Network.HTTP.Types.Method
20+
21+import Network.Wai.Middleware.Cors
22+
23+
24+getDBString :: IO B.ByteString
25+getDBString = do
26+ mDatabaseURL <- lookupEnv "DATABASE_URL"
27+ return $ B.pack $ fromMaybe "host=localhost port=5432 dbname=postgres connect_timeout=10" mDatabaseURL
28+
29+getServerPort :: IO Int
30+getServerPort = maybe 2000 read <$> lookupEnv "PORT"
31+
32+getConfig :: IO Config
33+getConfig = do
34+ databaseURL <- getDBString
35+ conn <- createConnectionPool databaseURL 1 0.5 10
36+ return $ Config conn
37+
38+runServer :: IO ()
39+runServer = do
40+ port <- getServerPort
41+ cfg <- getConfig
42+ let ctx = genAuthServerContext $ getPool cfg
43+ let s = hoistServerWithContext serverProxy contextProxy (flip runReaderT cfg) serverAPI
44+ runSettings (settings port) $ cors (const $ Just policy) $ serveWithContext serverProxy ctx s
45+ -- TODO: remove simpleCors
46+
47+-- runServer :: IO ()
48+-- runServer = do
49+-- s <- getServer
50+
51+policy :: CorsResourcePolicy
52+policy = CorsResourcePolicy {
53+ corsOrigins=Nothing,
54+ corsMethods=[methodGet, methodPost],
55+ corsRequestHeaders = ["content-type"],
56+ corsExposedHeaders = Nothing,
57+ corsMaxAge = Nothing,
58+ corsVaryOrigin = True,
59+ corsRequireOrigin = False,
60+ corsIgnoreFailures = True
61+}
62+
63+settings :: Int -> Settings
64+settings port = setPort port . setServerName "Denis" $ defaultSettings
denis/stack.yamlnew file+64
@@ -0,0 +1,64 @@
1+# This file was automatically generated by 'stack init'
2+#
3+# Some commonly used options have been documented as comments in this file.
4+# For advanced use and comprehensive documentation of the format, please see:
5+# https://docs.haskellstack.org/en/stable/yaml_configuration/
6+
7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8+# A snapshot resolver dictates the compiler version and the set of packages
9+# to be used for project dependencies. For example:
10+#
11+# resolver: lts-3.5
12+# resolver: nightly-2015-09-21
13+# resolver: ghc-7.10.2
14+#
15+# The location of a snapshot can be provided as a file or url. Stack assumes
16+# a snapshot provided as a file might change, whereas a url resource does not.
17+#
18+# resolver: ./custom-snapshot.yaml
19+# resolver: https://example.com/snapshots/2018-01-01.yaml
20+resolver: nightly-2018-09-28
21+
22+# User packages to be built.
23+# Various formats can be used as shown in the example below.
24+#
25+# packages:
26+# - some-directory
27+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
28+# - location:
29+# git: https://github.com/commercialhaskell/stack.git
30+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
31+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
32+# subdirs:
33+# - auto-update
34+# - wai
35+packages:
36+- .
37+# Dependency packages to be pulled from upstream that are not in the resolver
38+# using the same syntax as the packages field.
39+# (e.g., acme-missiles-0.3)
40+# extra-deps: []
41+
42+# Override default flag values for local packages and extra-deps
43+# flags: {}
44+
45+# Extra package databases containing global packages
46+# extra-package-dbs: []
47+
48+# Control whether we use the GHC we find on the path
49+# system-ghc: true
50+#
51+# Require a specific version of stack, using version ranges
52+# require-stack-version: -any # Default
53+# require-stack-version: ">=1.9"
54+#
55+# Override the architecture used by stack, especially useful on Windows
56+# arch: i386
57+# arch: x86_64
58+#
59+# Extra directories used by stack for building
60+# extra-include-dirs: [/path/to/dir]
61+# extra-lib-dirs: [/path/to/dir]
62+#
63+# Allow a newer minor version of GHC than the snapshot specifies
64+# compiler-check: newer-minor
stack.yamlnew file+66
@@ -0,0 +1,66 @@
1+# This file was automatically generated by 'stack init'
2+#
3+# Some commonly used options have been documented as comments in this file.
4+# For advanced use and comprehensive documentation of the format, please see:
5+# https://docs.haskellstack.org/en/stable/yaml_configuration/
6+
7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8+# A snapshot resolver dictates the compiler version and the set of packages
9+# to be used for project dependencies. For example:
10+#
11+# resolver: lts-3.5
12+# resolver: nightly-2015-09-21
13+# resolver: ghc-7.10.2
14+#
15+# The location of a snapshot can be provided as a file or url. Stack assumes
16+# a snapshot provided as a file might change, whereas a url resource does not.
17+#
18+# resolver: ./custom-snapshot.yaml
19+# resolver: https://example.com/snapshots/2018-01-01.yaml
20+resolver: nightly-2018-09-28
21+
22+# User packages to be built.
23+# Various formats can be used as shown in the example below.
24+#
25+# packages:
26+# - some-directory
27+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
28+# - location:
29+# git: https://github.com/commercialhaskell/stack.git
30+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
31+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
32+# subdirs:
33+# - auto-update
34+# - wai
35+packages:
36+- denis
37+# Dependency packages to be pulled from upstream that are not in the resolver
38+# using the same syntax as the packages field.
39+# (e.g., acme-missiles-0.3)
40+extra-deps:
41+- servant-options-0.1.0.0
42+
43+
44+# Override default flag values for local packages and extra-deps
45+# flags: {}
46+
47+# Extra package databases containing global packages
48+# extra-package-dbs: []
49+
50+# Control whether we use the GHC we find on the path
51+# system-ghc: true
52+#
53+# Require a specific version of stack, using version ranges
54+# require-stack-version: -any # Default
55+# require-stack-version: ">=1.9"
56+#
57+# Override the architecture used by stack, especially useful on Windows
58+# arch: i386
59+# arch: x86_64
60+#
61+# Extra directories used by stack for building
62+# extra-include-dirs: [/path/to/dir]
63+# extra-lib-dirs: [/path/to/dir]
64+#
65+# Allow a newer minor version of GHC than the snapshot specifies
66+# compiler-check: newer-minor