git.iko.soy/denis
on master help sign in
Merge pull request #140 from ilyakooo0/develop
757fdf9iko
denis/package.yaml+13
compare with master
unifiedsplit
@@ -63,6 +63,10 @@ dependencies:
63- blaze-html
63- blaze-html
64- servant-blaze
64- servant-blaze
65- random
65- random
66+- hspec
67+- generic-arbitrary
68+- quickcheck-instances
69+- http-client
66
70
67library:
71library:
68 source-dirs: src
72 source-dirs: src
@@ -105,4 +109,13 @@ executables:
105 - -rtsopts
109 - -rtsopts
106 - -with-rtsopts=-N
110 - -with-rtsopts=-N
107 dependencies:
111 dependencies:
112+ - denis
113+ test:
114+ main: Spec.hs
115+ source-dirs: src/test
116+ ghc-options:
117+ - -threaded
118+ dependencies:
119+ - QuickCheck
120+ - servant-quickcheck
108 - denis
121 - denis
denis/src/Data/PostElement.hs+7−5
@@ -15,7 +15,8 @@ module Data.PostElement (
15 MkElementRow,
15 MkElementRow,
16 PostElementRow(..),
16 PostElementRow(..),
17 PostElement(..),
17 PostElement(..),
18− elementsToRows
18+ elementsToRows,
19+ PostQuote(..)
19) where
20) where
20
21
21import Data.Int (Int64)
22import Data.Int (Int64)
@@ -40,9 +41,9 @@ instance ToSample (PostElement p) where
40data PostElement a = Markdown Text
41data PostElement a = Markdown Text
41 | Latex Text
42 | Latex Text
42 | Image Text
43 | Image Text
43− | Quote PostQuote
44+ | Quote ()
44 | Attachment Text
45 | Attachment Text
45− deriving (Show)
46+ deriving (Show, GHC.Generic)
46
47
47instance ToJSON (PostElement t) where
48instance ToJSON (PostElement t) where
48 toJSON (Markdown m) = object ["markdown" .= m]
49 toJSON (Markdown m) = object ["markdown" .= m]
@@ -69,7 +70,8 @@ elemenToRow f el = case el of
69 Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
70 Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
70 Latex l -> f Nothing (Just l) Nothing Nothing Nothing
71 Latex l -> f Nothing (Just l) Nothing Nothing Nothing
71 Image i -> f Nothing Nothing (Just i) Nothing Nothing
72 Image i -> f Nothing Nothing (Just i) Nothing Nothing
72− Quote q -> f Nothing Nothing Nothing (Just $ quoteId q) Nothing
73+ -- Quote q -> f Nothing Nothing Nothing (Just $ (quoteId q)) Nothing
74+ Quote _ -> f Nothing Nothing Nothing Nothing Nothing
73 Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
75 Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
74
76
75rowsToElement :: MkElementRow (Maybe (PostElement p))
77rowsToElement :: MkElementRow (Maybe (PostElement p))
@@ -105,7 +107,7 @@ data PostQuote = PostQuote {
105 quoteId :: Int64,
107 quoteId :: Int64,
106 quoteBody :: [PostElement PostQuote],
108 quoteBody :: [PostElement PostQuote],
107 quotePostId :: Int64
109 quotePostId :: Int64
108−} deriving (Show)
110+} deriving (Show, GHC.Generic)
109
111
110instance ToJSON PostQuote where
112instance ToJSON PostQuote where
111 toJSON (PostQuote qId pb pId) = object [
113 toJSON (PostQuote qId pb pId) = object [
denis/src/Server/Auth.hs+4−2
@@ -11,6 +11,7 @@
11 DeriveAnyClass,
11 DeriveAnyClass,
12 RecordWildCards #-}
12 RecordWildCards #-}
13{-# OPTIONS_GHC -Wno-orphans #-}
13{-# OPTIONS_GHC -Wno-orphans #-}
14+
14module Server.Auth (
15module Server.Auth (
15 checkToken,
16 checkToken,
16 cookieTokenKey,
17 cookieTokenKey,
@@ -19,7 +20,8 @@ module Server.Auth (
19 logIn,
20 logIn,
20 contextProxy,
21 contextProxy,
21 AuthenticationCredits(..),
22 AuthenticationCredits(..),
22− authenticationAPI
23+ authenticationAPI,
24+ TokenActivationData
23) where
25) where
24
26
25import Server.App
27import Server.App
@@ -160,7 +162,7 @@ data AuthenticationCookieData = AuthenticationCookieData {
160data TokenActivationData = TokenActivationData {
162data TokenActivationData = TokenActivationData {
161 tokenVerificationUserId :: UserId,
163 tokenVerificationUserId :: UserId,
162 tokenVerificationData :: BS.ByteString
164 tokenVerificationData :: BS.ByteString
163−} deriving (Show)
165+} deriving (Show, GHC.Generic)
164
166
165instance ToJSON TokenActivationData where
167instance ToJSON TokenActivationData where
166 toJSON (TokenActivationData uId vData) = object [
168 toJSON (TokenActivationData uId vData) = object [
denis/src/Server/Server.hs+14−5
@@ -1,7 +1,12 @@
1+{-# LANGUAGE
1−{-# LANGUAGE OverloadedStrings #-}
2+ OverloadedStrings,
3+ TypeOperators,
4+ DataKinds #-}
2
5
3module Server.Server (
6module Server.Server (
4− runServer
7+ runServer,
8+ hoistedServer,
9+ getConfig
5) where
10) where
6
11
7import Server.API
12import Server.API
@@ -49,6 +54,11 @@ getConfig = do
49 mail <- getMailConfig
54 mail <- getMailConfig
50 return $ Config conn crypto selfRoot mail
55 return $ Config conn crypto selfRoot mail
51
56
57+hoistedServer :: Logger -> Config -> Server API
58+hoistedServer logger cfg =
59+ let serverAPI = mkServerAPI logger
60+ in hoistServerWithContext serverProxy contextProxy (flip runReaderT cfg) serverAPI
61+
52runServer :: IO ()
62runServer :: IO ()
53runServer = do
63runServer = do
54 port <- getServerPort
64 port <- getServerPort
@@ -57,14 +67,13 @@ runServer = do
57 _ <- periodically (20 * minutes) $ runDbTask cfg pruneAuth
67 _ <- periodically (20 * minutes) $ runDbTask cfg pruneAuth
58 let ctx = genAuthServerContext $ getPool cfg
68 let ctx = genAuthServerContext $ getPool cfg
59 (middleLogger, logger) <- mkLogger 500
69 (middleLogger, logger) <- mkLogger 500
60− let serverAPI = mkServerAPI logger
70+ let s = hoistedServer logger cfg
61− let s = hoistServerWithContext serverProxy contextProxy (flip runReaderT cfg) serverAPI
62 runSettings (settings port) $ cors (const $ Just policy) . middleLogger $ serveWithContext serverProxy ctx s
71 runSettings (settings port) $ cors (const $ Just policy) . middleLogger $ serveWithContext serverProxy ctx s
63
72
64policy :: CorsResourcePolicy
73policy :: CorsResourcePolicy
65policy = CorsResourcePolicy {
74policy = CorsResourcePolicy {
66 corsOrigins = Just (["http://localhost:8080", "http://localhost:4000", "http://127.0.0.1:4000", "http://127.0.0.1:8080", "http://lvh.me:4000", "http://lvh.me:8080", "http://valera-kristina.herokuapp.com", "https://valera-kristina.herokuapp.com"], True), -- Nothing,
75 corsOrigins = Just (["http://localhost:8080", "http://localhost:4000", "http://127.0.0.1:4000", "http://127.0.0.1:8080", "http://lvh.me:4000", "http://lvh.me:8080", "http://valera-kristina.herokuapp.com", "https://valera-kristina.herokuapp.com"], True), -- Nothing,
67− corsMethods=[methodGet, methodPost],
76+ corsMethods=[methodGet, methodPost, methodDelete],
68 corsRequestHeaders = ["content-type"],
77 corsRequestHeaders = ["content-type"],
69 corsExposedHeaders = Nothing,
78 corsExposedHeaders = Nothing,
70 corsMaxAge = Nothing,
79 corsMaxAge = Nothing,
denis/src/test/Orphans.hsnew file+104
@@ -0,0 +1,104 @@
1+{-# LANGUAGE
2+ OverloadedStrings,
3+ TypeOperators,
4+ DataKinds,
5+ FlexibleInstances,
6+ UndecidableInstances #-}
7+
8+module Orphans where
9+
10+import Server.API
11+import Server.Server
12+import Test.QuickCheck
13+import Servant.QuickCheck
14+import Test.Hspec
15+import Server.App
16+import Servant.Server
17+import Data.User
18+import Servant.Server.Experimental.Auth
19+import Network.Wai
20+import Servant.QuickCheck.Internal.HasGenRequest
21+import Servant.API
22+import Server.Query.ComplexQuery
23+import Test.QuickCheck
24+import Server.Query.Pagination
25+import Test.QuickCheck.Arbitrary.Generic
26+import Data.Post
27+import Data.Channel.NamedChannel
28+import Test.QuickCheck.Instances
29+import Server.Auth
30+import Data.Query
31+import Data.User
32+import Data.PostElement
33+import Data.Channel.AnonymousChannel
34+import Data.Channel.NamedChannel
35+import Data.GroupChat
36+import Squeal.PostgreSQL.Schema
37+import Data.Message
38+
39+instance (Arbitrary i, Arbitrary r) => Arbitrary (PaginatingRequest i r) where
40+ arbitrary = genericArbitrary
41+ shrink = genericShrink
42+
43+instance Arbitrary PaginationDirection where
44+ arbitrary = elements [BackPagination, ForwardPagination]
45+
46+instance (Arbitrary u) => Arbitrary (NamedChannel u) where
47+ arbitrary = genericArbitrary
48+ shrink = genericShrink
49+
50+instance Arbitrary AuthenticationCredits where
51+ arbitrary = genericArbitrary
52+ shrink = genericShrink
53+
54+instance Arbitrary UserCreation where
55+ arbitrary = genericArbitrary
56+ shrink = genericShrink
57+
58+instance Arbitrary TokenActivationData where
59+ arbitrary = genericArbitrary
60+ shrink = genericShrink
61+
62+instance Arbitrary UserUpdate where
63+ arbitrary = genericArbitrary
64+ shrink = genericShrink
65+
66+instance Arbitrary PostCreation where
67+ arbitrary = genericArbitrary
68+ shrink = genericShrink
69+
70+instance Arbitrary (PostElement p) where
71+ arbitrary = genericArbitrary
72+ shrink = genericShrink
73+
74+instance Arbitrary PostQuote where
75+ arbitrary = genericArbitrary
76+ shrink = genericShrink
77+
78+instance Arbitrary AnonymousChannel where
79+ arbitrary = genericArbitrary
80+ shrink = genericShrink
81+
82+instance Arbitrary NamedChannelCreationRequest where
83+ arbitrary = genericArbitrary
84+ shrink = genericShrink
85+
86+instance Arbitrary GroupChat where
87+ arbitrary = genericArbitrary
88+ shrink = genericShrink
89+
90+instance Arbitrary GroupChatPermissions where
91+ arbitrary = genericArbitrary
92+ shrink = genericShrink
93+
94+instance Arbitrary GroupChatCreation where
95+ arbitrary = genericArbitrary
96+ shrink = genericShrink
97+
98+instance Arbitrary MessageCreation where
99+ arbitrary = genericArbitrary
100+ shrink = genericShrink
101+
102+instance (Arbitrary a) => Arbitrary (Jsonb a) where
103+ arbitrary = genericArbitrary
104+ shrink = genericShrink
denis/src/test/Spec.hsnew file+56
@@ -0,0 +1,56 @@
1+{-# LANGUAGE
2+ OverloadedStrings,
3+ TypeOperators,
4+ DataKinds,
5+ FlexibleInstances,
6+ UndecidableInstances,
7+ ScopedTypeVariables #-}
8+
9+import Server.API
10+import Server.Server
11+import Test.QuickCheck
12+import Servant.QuickCheck
13+import Test.Hspec
14+import Server.App
15+import Servant.Server
16+import Data.User
17+import Servant.Server.Experimental.Auth
18+import Network.Wai
19+import Servant.QuickCheck.Internal.HasGenRequest
20+import Servant.API
21+import Server.Query.ComplexQuery
22+import Orphans
23+import qualified Network.HTTP.Client as HTTP
24+import qualified Data.ByteString.Char8 as B
25+import qualified Data.ByteString.Lazy.Char8 as LB
26+
27+main :: IO ()
28+main = hspec goodAPISpec
29+
30+mockAuth :: Context (AuthHandler Request UserId ': '[])
31+mockAuth = mkAuthHandler (const $ return 3) :. EmptyContext
32+
33+goodAPISpec = describe "my server" $ do
34+
35+ it "follows best practices" $ do
36+ cfg' <- getConfig
37+ withServantServerAndContext serverProxy mockAuth (return $ hoistedServer (return "") cfg') $ \burl ->
38+ serverSatisfies serverProxy burl stdArgs{chatty=True} (
39+ printPredicate
40+ <%> not500
41+ <%> mempty)
42+
43+printPredicate = RequestPredicate $ \ req mgr -> do
44+ let url = HTTP.path req
45+ let (HTTP.RequestBodyLBS bs) = HTTP.requestBody req
46+ putStrLn . ("\t\t" <>) $ B.unpack url
47+ putStrLn $ LB.unpack bs
48+ putStrLn ""
49+ return []
50+
51+
52+instance (HasGenRequest a) => HasGenRequest (Authentication :> a) where
53+ genRequest (Proxy :: Proxy (Authentication :> a)) = genRequest (Proxy :: Proxy a)
54+
55+instance HasGenRequest api => HasGenRequest (ComplexQuery :> api) where
56+ genRequest (Proxy :: Proxy (ComplexQuery :> api)) = genRequest (Proxy :: Proxy api)