git.iko.soy/websuck1t
on c050296 help sign in
b7b8884
swap
0 ahead, 5 behind
LICENSEmode 100755 → 100644
since splitsnapshots
unifiedsplit

Only the mode changed.

Procfilemode 100755 → 100644

Only the mode changed.

Setup.hsmode 100755 → 100644

Only the mode changed.

app.jsonmode 100755 → 100644

Only the mode changed.

app/Main.hsmode 100755 → 100644+11−4
@@ -1,3 +1,5 @@
1+-- {-# LANGUAGE OverloadedStrings #-}
2+
1module Main where
3module Main where
2
4
3import Network.Wai.Handler.Warp (run)
5import Network.Wai.Handler.Warp (run)
@@ -5,12 +7,17 @@ import Servant.Server (serve)
5import System.Environment
7import System.Environment
6import Lib
8import Lib
7import Network.Wai.Middleware.Cors
9import Network.Wai.Middleware.Cors
10+import Database.Beam.Postgres (connectPostgreSQL)
11+import Data.Maybe
12+import qualified Data.ByteString.Char8 as B
8
13
9main :: IO ()
14main :: IO ()
10main = do
15main = do
11− env <- lookupEnv "PORT"
16+ mPort <- lookupEnv "PORT"
12− let port = maybe 2000 read env :: Int
17+ let port = maybe 2000 read mPort :: Int
13 putStrLn $ "Starting on port: " ++ show port
18 putStrLn $ "Starting on port: " ++ show port
14− print env
19+ mDatabaseURL <- lookupEnv "DATABASE_URL"
20+ let databaseURL = fromMaybe "host=localhost port=5432 dbname=postgres connect_timeout=10" mDatabaseURL
21+ conn <- connectPostgreSQL $ B.pack databaseURL
15− srv <- createServer
22+ srv <- createServer conn
16 run port $ simpleCors $ serve server srv
23 run port $ simpleCors $ serve server srv
docs.mdmode 100755 → 100644

Only the mode changed.

docs/Docs.hsmode 100755 → 100644+23−23
@@ -19,34 +19,34 @@ import Data.Foldable (fold)
19import Servant.API.WebSocket
19import Servant.API.WebSocket
20import Control.Lens
20import Control.Lens
21
21
22−main = writeFile "docs.md" . markdown . docs . pretty $ server
22+main = return () -- writeFile "docs.md" . markdown . docs . pretty $ server
23
23
24−-- instance ToSample User
24+-- -- instance ToSample User
25−instance ToCapture (Capture "first" T.Text) where
25+-- instance ToCapture (Capture "first" T.Text) where
26− toCapture _ = DocCapture "first" "The first name of the user."
26+-- toCapture _ = DocCapture "first" "The first name of the user."
27
27
28−instance ToSample Foo.Data.Post where
28+-- instance ToSample Foo.Data.Post where
29− toSamples _ = samples $ Post `fmap` [1, 4, 7, 194] <*> [4, 7, 92] <*> ["This is the post body", "This is another post body"]
29+-- toSamples _ = samples $ Post `fmap` [1, 4, 7, 194] <*> [4, 7, 92] <*> ["This is the post body", "This is another post body"]
30
30
31−instance ToSample User where
31+-- instance ToSample User where
32− toSamples _ = samples [
32+-- toSamples _ = samples [
33− User (UserName "Seva" "Leonidovich") 1,
33+-- User (UserName "Seva" "Leonidovich") 1,
34− User (UserName "Foo" "Barovich") 42,
34+-- User (UserName "Foo" "Barovich") 42,
35− User (UserName "Bar" "Fooovich") 69,
35+-- User (UserName "Bar" "Fooovich") 69,
36− User (UserName "Qux" "Quixovich") 8]
36+-- User (UserName "Qux" "Quixovich") 8]
37
37
38−instance ToCapture (Capture "second" T.Text) where
38+-- instance ToCapture (Capture "second" T.Text) where
39− toCapture _ = DocCapture "second" "The second name of the user."
39+-- toCapture _ = DocCapture "second" "The second name of the user."
40
40
41−instance ToSample (TokenizedResponse [Foo.Data.Post]) where
41+-- instance ToSample (TokenizedResponse [Foo.Data.Post]) where
42− toSamples _ = samples $ TokenizedResponse `fmap` [1, 46, 193, 7] <*> [map snd $ toSamples (Proxy :: Proxy Foo.Data.Post)]
42+-- toSamples _ = samples $ TokenizedResponse `fmap` [1, 46, 193, 7] <*> [map snd $ toSamples (Proxy :: Proxy Foo.Data.Post)]
43
43
44−instance ToCapture (Capture "id" Int) where
44+-- instance ToCapture (Capture "id" Int) where
45− toCapture _ = DocCapture "id" "The id of the entity you want to query."
45+-- toCapture _ = DocCapture "id" "The id of the entity you want to query."
46
46
47−instance ToCapture (Capture "token" Int) where
47+-- instance ToCapture (Capture "token" Int) where
48− toCapture _ = DocCapture "token" "The token, recieved wit the previuos request"
48+-- toCapture _ = DocCapture "token" "The token, recieved wit the previuos request"
49
49
50−instance HasDocs WebSocketPending where
50+-- instance HasDocs WebSocketPending where
51− docsFor Proxy (endpoint, action) =
51+-- docsFor Proxy (endpoint, action) =
52− docsFor (Proxy :: Proxy Raw) (endpoint, action & notes <>~ [DocNote "title" ["not title"]])
52+-- docsFor (Proxy :: Proxy Raw) (endpoint, action & notes <>~ [DocNote "title" ["not title"]])
package.yamlmode 100755 → 100644+7
@@ -37,6 +37,13 @@ dependencies:
37- websockets
37- websockets
38- lens
38- lens
39- wai-cors
39- wai-cors
40+- beam-core
41+- beam-postgres
42+- postgresql-simple
43+- random-shuffle
44+- socket-io
45+- engine-io
46+- engine-io-wai
40
47
41library:
48library:
42 source-dirs: src
49 source-dirs: src
readme.mdmode 100755 → 100644+87−101
@@ -6,64 +6,9 @@ _url: [`https://websuck1t.herokuapp.com`](https://websuck1t.herokuapp.com)_
6
6
7## GET /posts/all
7## GET /posts/all
8
8
9−### Response:
9+_start with: [`https://websuck1t.herokuapp.com/posts/all`](https://websuck1t.herokuapp.com/posts/all)_
10−
11−- Status code 200
12−- Headers: []
13−
14−- Supported content types are:
15−
16− - `application/json`
17−
18−- Example (`application/json`):
19−
20−```javascript
21−{
22− "token": 1,
23− "response": [
24− {
25− "postBody": "This is the post body",
26− "postAuthor": 4,
27− "postId": 1
28− },
29− {
30− "postBody": "This is another post body",
31− "postAuthor": 4,
32− "postId": 2
33− },
34− {
35− "postBody": "This is the post body",
36− "postAuthor": 7,
37− "postId": 3
38− },
39− {
40− "postBody": "This is another post body",
41− "postAuthor": 7,
42− "postId": 4
43− },
44− {
45− "postBody": "This is the post body",
46− "postAuthor": 92,
47− "postId": 5
48− },
49− {
50− "postBody": "This is another post body",
51− "postAuthor": 92,
52− "postId": 6
53− }
54− ]
55−}
56−```
57−
58−## GET /users/:id
59−
60−Retrieves a user with the given `id`.
61−
62−#### If there is no user with the given `id`, the method returns error `404`.
63
10
64−### Captures:
11+Use this _url_ to get the token every time when application begins and previous session was closed
65−
66−- *id*: The id of the entity you want to query.
67
12
68### Response:
13### Response:
69
14
@@ -78,64 +23,41 @@ Retrieves a user with the given `id`.
78
23
79```javascript
24```javascript
80{
25{
81− "userName": {
26+ "token": 1828,
82− "secondName": "Leonidovich",
27+ "response": {
83− "firstName": "Seva"
28+ "deleted": [],
29+ "added": [
30+ 1844,
31+ 1845,
32+ 1846
33+ ]
84− },
34+ }
85− "userId": 1
86}
35}
87−```
88−
89−- Example (`application/json`):
90
36
91−```javascript
92−{
93− "userName": {
94− "secondName": "Barovich",
95− "firstName": "Foo"
96− },
97− "userId": 42
98−}
99```
37```
100
38
101−- Example (`application/json`):
39+### Response fields
102
40
103−```javascript
41+- "token" to further use it in subscription to web socket
104−{
42+- "response" to start with the given number of posts in table
105− "userName": {
106− "secondName": "Fooovich",
107− "firstName": "Bar"
108− },
109− "userId": 69
110−}
111−```
112
43
113−- Example (`application/json`):
44+## socket.io /posts/subscribe/
114
45
115−```javascript
46+_NOTE: subscribe to the `"postUpdates"` event before submitting the token to `"subscribeWithToken"`._
116−{
117− "userName": {
118− "secondName": "Quixovich",
119− "firstName": "Qux"
120− },
121− "userId": 8
122−}
123−```
124
47
125−## WebSocket /posts/subscribe/:token
48+You access the web socket with the socket io protocol. You will most likely need to install a library.
126
49
127−You access the web socket with the web socket protocol. I. e. `https://` -> `ws://`.
50+### Connecting
128
51
129−Open a web socket from the given `token` for receiving events about new and deleted posts.
52+To start recieving events you send a `"subscribeWithToken"` event with a single `Int` as the messages body. The `Int` should be the last _token_ you recieved from any API.
130
53
131−#### Returns error `498` if the supplied token has expired or is invalid.
54+#### Response
132
55
56+After sending the request, _you_ will receive a `"subscribeWithToken"` event with a single `Bool` in the message of the event. The `Bool` indicates whether you have supplied a valid token. If the response is `true`, you are now subscribed to recieve updates. If thge response was `false`, nothing happens, you will not be sent any updates.
133
57
134−### Captures:
58+### Receiving updates
135−
136−- *token*: The token, received with the previous request.
137
59
138−### Response:
60+Updates will be sent to you on the `"postUpdates"` event. The event message will contain the following JSON Object (same as `/posts/all`):
139
61
140```javascript
62```javascript
141{
63{
@@ -157,6 +79,8 @@ Open a web socket from the given `token` for receiving events about new and dele
157
79
158## GET /posts/:id
80## GET /posts/:id
159
81
82+_url: [`https://websuck1t.herokuapp.com/posts/{id}`](https://websuck1t.herokuapp.com/posts/1)_
83+
160#### If there is no post with the given `id`, the method returns error `404`.
84#### If there is no post with the given `id`, the method returns error `404`.
161
85
162### Captures:
86### Captures:
@@ -221,3 +145,65 @@ Open a web socket from the given `token` for receiving events about new and dele
221 "postId": 1
145 "postId": 1
222}
146}
223```
147```
148+
149+
150+## GET /users/:id
151+
152+_url: [`https://websuck1t.herokuapp.com/users/{id}`](https://websuck1t.herokuapp.com/users/1)_
153+
154+Retrieves a user with the given `id`.
155+
156+#### If there is no user with the given `id`, the method returns error `404`.
157+
158+### Captures:
159+
160+- *id*: The id of the entity you want to query.
161+
162+### Response:
163+
164+- Status code 200
165+- Headers: []
166+
167+- Supported content types are:
168+
169+ - `application/json`
170+
171+- Example (`application/json`):
172+
173+```javascript
174+{
175+ "secondName": "Leonidovich",
176+ "firstName": "Seva",
177+ "userId": 1
178+}
179+```
180+
181+- Example (`application/json`):
182+
183+```javascript
184+{
185+ "secondName": "Barovich",
186+ "firstName": "Foo",
187+ "userId": 42
188+}
189+```
190+
191+- Example (`application/json`):
192+
193+```javascript
194+{
195+ "secondName": "Fooovich",
196+ "firstName": "Bar",
197+ "userId": 69
198+}
199+```
200+
201+- Example (`application/json`):
202+
203+```javascript
204+{
205+ "secondName": "Quixovich",
206+ "firstName": "Qux",
207+ "userId": 8
208+}
209+```
src/Data/CyclicBuffer.hsmode 100755 → 100644

Only the mode changed.

src/Data/Error.hsmode 100755 → 100644

Only the mode changed.

src/Foo/Data.hsmode 100755 → 100644+173−89
@@ -1,5 +1,12 @@
1{-# LANGUAGE DeriveGeneric #-}
1{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GADTs #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeApplications #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+
3
10
4module Foo.Data
11module Foo.Data
5 (
12 (
@@ -9,7 +16,6 @@ module Foo.Data
9 createApp,
16 createApp,
10 createConfig,
17 createConfig,
11 User(..),
18 User(..),
12− UserName(..),
13 Config,
19 Config,
14 updates,
20 updates,
15 allUsers,
21 allUsers,
@@ -17,12 +23,16 @@ module Foo.Data
17 UserId,
23 UserId,
18 PostId,
24 PostId,
19 Post(..),
25 Post(..),
26+ postId,
20 allPosts,
27 allPosts,
21 addConnection,
28 addConnection,
22 removeConnection,
29 removeConnection,
23 TokenizedResponse(..),
30 TokenizedResponse(..),
24 Update(..),
31 Update(..),
25− getToken
32+ getToken,
33+ Token,
34+ subscribeWithToken,
35+ postUpdates
26 ) where
36 ) where
27
37
28import GHC.Conc
38import GHC.Conc
@@ -50,6 +60,14 @@ import qualified Data.CyclicBuffer as CB
50import Data.Set ((\\), union)
60import Data.Set ((\\), union)
51import Data.Monoid
61import Data.Monoid
52import Debug.Trace
62import Debug.Trace
63+import Database.Beam
64+import qualified Database.Beam.Postgres as P
65+import Database.Beam.Query
66+import Database.PostgreSQL.Simple (withTransaction)
67+import Database.Beam.Backend.SQL.BeamExtensions
68+import System.Random.Shuffle
69+import Network.SocketIO
70+import Network.EngineIO (SocketId)
53
71
54type App = ReaderT Config Handler
72type App = ReaderT Config Handler
55
73
@@ -57,35 +75,35 @@ class HasConfig c where
57 getCfg :: c -> Config
75 getCfg :: c -> Config
58
76
59allUsers :: App [User]
77allUsers :: App [User]
60−allUsers = ask >>= liftIO . fmap M.elems . readTVarIO . users
78+allUsers = asks dbConn >>= \conn -> liftIO . P.runBeamPostgres conn . runSelectReturningList . select . all_ . users $ socialDb
61
79
62post :: PostId -> App Post
80post :: PostId -> App Post
63post pId = do
81post pId = do
64− cfg <- ask
82+ conn <- asks dbConn
65− u <- liftIO . atomically . fmap (M.lookup pId) . readTVar . posts $ cfg
83+ u <- liftIO . P.runBeamPostgres conn . runSelectReturningOne . flip lookup_ (PostId pId) . posts $ socialDb
66 case u of
84 case u of
67 Just u -> return u
85 Just u -> return u
68 Nothing -> throwError err404
86 Nothing -> throwError err404
69
87
70user :: UserId -> App User
88user :: UserId -> App User
71user uId = do
89user uId = do
72− cfg <- ask
90+ conn <- asks dbConn
73− u <- liftIO . atomically . fmap (M.lookup uId) . readTVar . users $ cfg
91+ u <- liftIO . P.runBeamPostgres conn . runSelectReturningOne . flip lookup_ (UserId uId) . users $ socialDb
74 case u of
92 case u of
75 Just u -> return u
93 Just u -> return u
76 Nothing -> throwError err404
94 Nothing -> throwError err404
77
95
78−allPosts :: App (STM [Post])
96+allPosts :: App [Post]
79−allPosts = asks $ fmap M.elems . readTVar . posts
97+allPosts = asks dbConn >>= \conn -> liftIO . P.runBeamPostgres conn . runSelectReturningList . select . all_ . posts $ socialDb
80
98
81getToken :: App (STM Token)
99getToken :: App (STM Token)
82getToken = asks $ fmap CB.lastToken . readTVar . updates
100getToken = asks $ fmap CB.lastToken . readTVar . updates
83
101
84−createConfig :: IO Config
102+createConfig :: P.Connection -> IO Config
85−createConfig = do
103+createConfig conn = do
86 mng <- newManager tlsManagerSettings
104 mng <- newManager tlsManagerSettings
87− cfg <- atomically $ Config <$> newTVar 0 <*> newTVar 0 <*> newTVar M.empty <*> newTVar M.empty <*> return mng <*> newTVar M.empty <*> newTVar 0 <*> newTVar (CB.empty 20)
105+ cfg <- atomically $ Config <$> return conn <*> return mng <*> newTVar M.empty <*> newTVar 0 <*> newTVar (CB.empty 20)
88− forkIO . forever $ threadDelay 2000000 >> (runHandler . createApp cfg $ startAddingPosts 20 cfg >>= uncurry sendUpdate)
106+ forkIO . forever $ threadDelay 7000000 >> (runHandler . createApp cfg $ startAddingPosts 25 cfg >>= uncurry sendUpdate)
89 return cfg
107 return cfg
90
108
91type Token = Int
109type Token = Int
@@ -116,18 +134,32 @@ instance Semigroup Update where
116instance Monoid Update where
134instance Monoid Update where
117 mempty = Update S.empty S.empty
135 mempty = Update S.empty S.empty
118
136
119−addConnection :: HasConfig c => c -> Connection -> STM ConnectionId
137+addConnection :: HasConfig c => c -> Socket -> STM SocketId
120addConnection c conn = do
138addConnection c conn = do
121 let cfg = getCfg c
139 let cfg = getCfg c
140+ let sId = socketId conn
122− lastID <- fmap (+1) . readTVar . lastConnection $ cfg
141+ -- lastID <- fmap (+1) . readTVar . lastConnection $ cfg
123− flip writeTVar lastID . lastConnection $ cfg
142+ -- flip writeTVar lastID . lastConnection $ cfg
124− modifyTVar (connections cfg) $ M.insert lastID conn
143+ modifyTVar (connections cfg) $ M.insert sId conn
125− return lastID
144+ return sId
126
145
127−removeConnection :: HasConfig c => c -> ConnectionId -> STM ()
146+removeConnection :: HasConfig c => c -> Socket -> STM ()
128−removeConnection c cId = do
147+removeConnection c conn = do
129 let cfg = getCfg c
148 let cfg = getCfg c
149+ let sId = socketId conn
130− modifyTVar (connections cfg) $ M.delete cId
150+ modifyTVar (connections cfg) $ M.delete sId
151+
152+
153+-- subscribe :: MonadIO m => Config -> Socket -> m ()
154+-- subscribe cfg conn = do
155+-- cId <- liftSTM $ addConnection cfg conn
156+-- -- liftIO $ flip finally (atomically $ removeConnection cfg cId) $ forever $ do
157+-- -- _ <- receiveDataMessage conn
158+-- -- return ()
159+-- return ()
160+
161+-- unsubscribe :: MonadIO m => Config -> Socket -> m ()
162+-- unsubscribe cfg conn = liftIO . atomically $ removeConnection cfg cId
131
163
132
164
133
165
@@ -139,12 +171,9 @@ type PostId = Int
139type ConnectionId = Int
171type ConnectionId = Int
140
172
141data Config = Config {
173data Config = Config {
142− lastUserID :: TVar UserId,
174+ dbConn :: P.Connection,
143− lastPostID :: TVar PostId,
144− users :: TVar (M.Map Int User),
145− posts :: TVar (M.Map Int Post),
146 manager :: Manager,
175 manager :: Manager,
147− connections :: TVar (M.Map ConnectionId Connection),
176+ connections :: TVar (M.Map SocketId Socket),
148 lastConnection :: TVar ConnectionId,
177 lastConnection :: TVar ConnectionId,
149 updates :: TVar (CB.CyclicBuffer Update)
178 updates :: TVar (CB.CyclicBuffer Update)
150}
179}
@@ -152,94 +181,149 @@ data Config = Config {
152instance HasConfig Config where
181instance HasConfig Config where
153 getCfg = id
182 getCfg = id
154
183
155−-- startAddingUsers :: Config -> App ()
156−-- startAddingUsers cfg = do
157−-- a <- liftIO $ loremBacon (manager cfg) (Just AllMeat) (Just 2) (Just False)
158−-- let t = fromMaybe ["None", "None"] a
159−-- liftIO . atomically $ newUser cfg (t !! 0) (t !! 1)
160−-- return ()
161−
162startAddingPosts :: Int -> Config -> App (Token, Update)
184startAddingPosts :: Int -> Config -> App (Token, Update)
163startAddingPosts lim cfg = do
185startAddingPosts lim cfg = do
164 cfg <- ask
186 cfg <- ask
187+ let conn = dbConn cfg
165− let us = users cfg
188+ -- let us = users socialDb
166− let ps = posts cfg
189+ -- let ps = posts socialDb
167
190
168 a <- liftIO $ loremBacon (manager cfg) (Just AllMeat) (Just lim) (Just 0)
191 a <- liftIO $ loremBacon (manager cfg) (Just AllMeat) (Just lim) (Just 0)
169 g <- liftIO newStdGen
192 g <- liftIO newStdGen
170 let rns = randoms g
193 let rns = randoms g
171−
194+
172 let t = fromMaybe (repeat "None") a
195 let t = fromMaybe (repeat "None") a
173− liftIO . atomically $ do
196+
174− uu <- readTVar us
197+ let deleteCount = 3
175− let uSize = M.size uu
198+
176− if uSize >= 1 then do
199+ (deletedIds, addedIds) <- join . liftIO . withTransaction conn . return $ do
177− pp <- readTVar ps
200+ userIds <- liftIO . P.runBeamPostgres conn . runSelectReturningList . select $ do
178− let toDeleteIndex = head rns `mod` M.size pp
201+ uc <- all_ . users $ socialDb
179− let deletedKey = fst $ M.elemAt toDeleteIndex pp
202+ pure (userId uc)
180− dd <- if M.size pp > 0 then writeTVar ps (M.deleteAt toDeleteIndex pp) >> return [deletedKey]
203+
181− else return []
204+ if length userIds <= 0 then return ([],[])
205+ else do
206+ postIds <- liftIO . P.runBeamPostgres conn . runSelectReturningList . select $ do
207+ uc <- all_ . posts $ socialDb
208+ pure (postId uc)
209+
210+
211+ let postCount = length postIds
212+ let toDeleteIndecies = if postCount == 0 then [] else take deleteCount $ shuffle' postIds postCount g
213+
182− let toAdd = max 0 $ lim - (M.size pp - 1)
214+ let toAdd = max 0 $ lim - length postIds + length toDeleteIndecies
183− add <- fmap (map postId) $ forM (zip rns $ take toAdd t) $ \(rnd, t) -> newPost cfg (randomFrom rnd uu) t
215+
216+ -- Just deletedPost <- liftIO . P.runBeamPostgres conn . runSelectReturningOne . select . limit_ 1 . offset_ (fromIntegral $ toDeleteIndex - 1) . all_ . posts $ socialDb
217+ -- let deletedId = postId deletedPost
218+
219+ unless (length toDeleteIndecies <= 0) $
220+ liftIO . P.runBeamPostgres conn . runDelete $
221+ delete (posts socialDb) ((`in_` map val_ toDeleteIndecies) . postId)
222+
223+ nIds <- liftIO . P.runBeamPostgres conn . runInsertReturningList (posts socialDb) $ insertExpressions $ take toAdd . flip map (zip rns t) $ \(r, t) -> Post default_ (val_ (userIds %! r)) (val_ t)
224+
225+ return (toDeleteIndecies, map postId nIds)
226+
227+ liftIO . atomically $ do
184− let upd = Update (S.fromList add) (S.fromList dd)
228+ let upd = Update (S.fromList addedIds) (S.fromList deletedIds)
185− let uppT = updates cfg
229+ let uppT = updates cfg
186− upp <- readTVar uppT
230+ upp <- readTVar uppT
187− let (token, upp') = CB.insert upp upd
231+ let (token, upp') = CB.insert upp upd
188− writeTVar uppT upp'
232+ writeTVar uppT upp'
189− return (token, upd)
233+ return (token, upd)
190− else return (0, mempty)
191
234
192sendUpdate :: Token -> Update -> App ()
235sendUpdate :: Token -> Update -> App ()
193sendUpdate t u = do
236sendUpdate t u = do
194 cfg <- ask
237 cfg <- ask
195 conns <- fmap M.elems . liftIO . readTVarIO $ connections cfg
238 conns <- fmap M.elems . liftIO . readTVarIO $ connections cfg
239+ forM conns $ \ conn -> emitTo conn postUpdates $ TokenizedResponse t u
196− liftIO $ forM conns $ flip sendTextData $ encode $ TokenizedResponse t u
240+ -- liftIO $ forM conns $ flip sendTextData $ encode $ TokenizedResponse t u
197 return ()
241 return ()
198
242
243+modIndex :: [a] -> Int -> a
244+modIndex aa i = aa !! (i `mod` length aa)
245+
246+infixl 5 %!
247+(%!) = modIndex
248+
249+
199randomFrom :: Int -> M.Map k v -> k
250randomFrom :: Int -> M.Map k v -> k
200randomFrom g as = M.keys as !! (abs g `mod` M.size as)
251randomFrom g as = M.keys as !! (abs g `mod` M.size as)
201
252
202−newUser :: Config -> Text -> Text -> STM User
253+newUser :: Config -> Text -> Text -> IO [User]
203newUser cfg first second = do
254newUser cfg first second = do
204− let lastID = lastUserID cfg
255+ let conn = dbConn cfg
205− let us = users cfg
256+ P.runBeamPostgres conn . runInsertReturningList (users socialDb) $ insertExpressions [User default_ (val_ first) (val_ second)]
206− do
257+
207− id <- readTVar lastID
258+
208− writeTVar lastID (id+1)
209− let user = User (UserName first second) id
210− oldUsers <- readTVar us
211− writeTVar us $ M.insert id user oldUsers
212− return user
213−
214−newPost :: Config -> UserId -> Text -> STM Post
259+-- newPost :: Config -> UserId -> Text -> STM Post
215−newPost cfg user body = do
260+-- newPost cfg user body = do
216− let lastId = lastPostID cfg
261+-- let lastId = lastPostID cfg
217− let ps = posts cfg
262+-- let ps = posts cfg
218− do
263+-- do
219− id <- readTVar lastId
264+-- id <- readTVar lastId
220− writeTVar lastId (id+1)
265+-- writeTVar lastId (id+1)
221− let p = Post id user body
266+-- let p = Post id user body
222− modifyTVar ps $ M.insert id p
267+-- modifyTVar ps $ M.insert id p
223− return p
268+-- return p
224−
269+
225−data User = User {
270+data UserT f = User {
226− userName :: UserName,
227− userId :: UserId
271+ userId :: Columnar f UserId,
272+ firstName :: Columnar f Text,
273+ secondName :: Columnar f Text
228} deriving Generic
274} deriving Generic
229
275
230−data Post = Post {
276+instance Beamable UserT
277+
278+type User = UserT Identity
279+
280+instance Table UserT where
281+ data PrimaryKey UserT f = UserId (Columnar f UserId)
282+ deriving Generic
283+
284+ primaryKey = UserId . userId
285+
286+instance Beamable (PrimaryKey UserT)
287+
288+data PostT f = Post {
231− postId :: PostId,
289+ postId :: Columnar f PostId,
232− postAuthor :: UserId,
290+ postAuthor :: Columnar f UserId,
233− postBody :: Text
291+ postBody :: Columnar f Text
234} deriving Generic
292} deriving Generic
235
293
294+instance Beamable PostT
295+
296+type Post = PostT Identity
297+
236instance ToJSON User
298instance ToJSON User
237instance ToJSON Post
299instance ToJSON Post
238
300
239−data UserName = UserName {
301+instance Table PostT where
240− firstName :: Text,
302+ data PrimaryKey PostT f = PostId (Columnar f PostId)
241− secondName :: Text
303+ deriving Generic
242−} deriving (Generic)
304+
305+ primaryKey = PostId . postId
243
306
244−instance ToJSON UserName
307+instance Beamable (PrimaryKey PostT)
308+
309+data SocialDb f = SocialDb {
310+ users :: f (TableEntity UserT),
311+ posts :: f (TableEntity PostT)
312+} deriving Generic
245
313
314+instance Database be SocialDb
315+
316+socialDb :: DatabaseSettings be SocialDb
317+socialDb = defaultDbSettings `withDbModification`
318+ dbModification {
319+ users = modifyTable id $ tableModification {
320+ firstName = "firstname",
321+ secondName = "secondname"
322+ }
323+ }
324+
325+subscribeWithToken :: Text
326+subscribeWithToken = "subscribeWithToken"
327+postUpdates :: Text
328+postUpdates = "postUpdates"
329+
src/Lib.hsmode 100755 → 100644+90−49
@@ -1,6 +1,9 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE TypeOperators #-}
2{-# LANGUAGE TypeOperators #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+
4
7
5module Lib
8module Lib
6 ( server,
9 ( server,
@@ -26,76 +29,114 @@ import Data.Aeson
26import qualified Data.Set as S
29import qualified Data.Set as S
27import Data.CyclicBuffer
30import Data.CyclicBuffer
28import Data.Foldable (fold)
31import Data.Foldable (fold)
29−
32+import qualified Database.Beam.Postgres as P
33+-- import Network.Wai
34+import Network.EngineIO.Wai (toWaiApplication, waiAPI)
35+import Network.SocketIO
36+import Control.Monad.State
37+import Debug.Trace
30
38
31type API = "users" :> Capture "id" UserId :> Get '[JSON] User
39type API = "users" :> Capture "id" UserId :> Get '[JSON] User
32 :<|> "users" :> "add" :> Capture "first" Text :> Capture "second" Text :> Get '[JSON] [User]
40 :<|> "users" :> "add" :> Capture "first" Text :> Capture "second" Text :> Get '[JSON] [User]
33 :<|> "users" :> "all" :> Get '[JSON] [User]
41 :<|> "users" :> "all" :> Get '[JSON] [User]
34 :<|> "posts" :> Capture "id" PostId :> Get '[JSON] D.Post
42 :<|> "posts" :> Capture "id" PostId :> Get '[JSON] D.Post
35− :<|> "posts" :> "all" :> Get '[JSON] (TokenizedResponse [D.Post])
43+ :<|> "posts" :> "all" :> Get '[JSON] (TokenizedResponse Update)
36− :<|> "posts" :> "subscribe" :> Capture "token" Int :> WebSocketPending
44+ :<|> "posts" :> "subscribe" :> Raw --Capture "token" Int :> WebSocketPending
37
45
38−createServer :: IO (Server API)
46+createServer :: P.Connection -> IO (Server API)
39−createServer = do
47+createServer pConn = do
40− cfg <- createConfig
48+ cfg <- createConfig pConn
41− atomically $ newUser cfg "Kostya" "Designerovich"
49+ -- newUser cfg "Kostya" "Designerovich"
42− atomically $ newUser cfg "Anna" "Androidovna"
50+ -- newUser cfg "Anna" "Androidovna"
43− atomically $ newUser cfg "Darya" "Aiphonovna"
51+ -- newUser cfg "Darya" "Aiphonovna"
44− atomically $ newUser cfg "Ilya" "Serverovich"
52+ -- newUser cfg "Ilya" "Serverovich"
53+ -- newUser cfg "Константин" "Дудосерович"
54+ subscribePostsEndpoint <- subscribePosts cfg
55+ let app = toWaiApplication subscribePostsEndpoint :: Application
56+ let sAPI = serverAPI app
45− return $ hoistServer server (createApp cfg) serverAPI
57+ return $ hoistServer server (createApp cfg) sAPI
46
58
47server :: Proxy API
59server :: Proxy API
48server = Proxy
60server = Proxy
49
61
50−serverAPI :: ServerT API App
62+serverAPI :: Application -> ServerT API App
51−serverAPI =
63+serverAPI app = user
52− user
53− :<|> createUserPath
64+ :<|> createUserPath
54− :<|> allUsers
65+ :<|> allUsers
55− :<|> post
66+ :<|> post
56− :<|> returnPosts
67+ :<|> returnPosts
68+ :<|> pure app
57− :<|> validateConnection
69+ -- :<|> validateConnection
58
70
59createUserPath :: Text -> Text -> App [User]
71createUserPath :: Text -> Text -> App [User]
60createUserPath first second = do
72createUserPath first second = do
61 cfg <- ask
73 cfg <- ask
62− liftIO . atomically $ newUser cfg first second
74+ liftIO $ newUser cfg first second
63 allUsers
75 allUsers
64
76
65−returnPosts :: App (TokenizedResponse [D.Post])
77+returnPosts :: App (TokenizedResponse Update)
66returnPosts = do
78returnPosts = do
67 posts <- allPosts
79 posts <- allPosts
68 t <- getToken
80 t <- getToken
69− liftIO $ atomically $ TokenizedResponse <$> t <*> posts
81+ liftIO $ atomically $ TokenizedResponse <$> t <*> (pure $ flip Update (S.empty) $ S.fromList $ Prelude.map D.postId posts)
70
82
71−invalidTokenError :: RejectRequest
83+-- invalidTokenError :: RejectRequest
72−invalidTokenError = defaultRejectRequest {
84+-- invalidTokenError = defaultRejectRequest {
73− rejectCode = 498,
85+-- rejectCode = 498,
74− rejectMessage = "The supplied token is not valid" }
86+-- rejectMessage = "The supplied token is not valid" }
75
87
76−validateConnection :: Int -> PendingConnection -> App ()
88+-- validToken :: Token -> App Bool
77−validateConnection t pc = do
89+-- validToken t pc = do
78− cfg <- ask
90+-- cfg <- ask
79− (cyc, token) <- liftIO $ atomically $ do
91+-- (cyc, token) <- liftIO $ atomically $ do
80− uu <- readTVar $ updates cfg
92+-- uu <- readTVar $ updates cfg
81− return (getFrom uu t, lastToken uu)
93+-- return (getFrom uu t, lastToken uu)
82− case cyc of
94+-- return $ case cyc of
83− Nothing -> liftIO $ rejectRequestWith pc invalidTokenError
95+-- Nothing -> False
84− Just uu -> do
96+-- Just uu -> True
85− conn <- liftIO $ acceptRequest pc
97+
86− liftIO $ sendTextData conn $ encode $ TokenizedResponse token $ fold uu
98+
87− subscribe conn
99+
88− return ()
100+-- subscribePosts :: Config -> IO (m())
89−
101+subscribePosts cfg = do
90−subscribe :: Connection -> App ()
102+ handle <- initialize waiAPI $ subscriptionHandler cfg
91−subscribe conn = do
103+ return handle
92− cfg <- ask
104+
93− cId <- liftSTM $ addConnection cfg conn
105+-- subscriptionHandler :: MonadIO m => Config -> StateT RoutingTable (ReaderT Socket m) a
106+subscriptionHandler :: MonadState RoutingTable m => Config -> m ()
107+subscriptionHandler cfg = do
108+ on "test" $ \ (i::Int) -> do
94− -- liftIO $ sendDataMessage conn . Binary . encode $ D.TokenizedResponse 1 (Update (S.fromList [1, 2, 3]) (S.fromList [4, 2,6]))
109+ emit "test" $ Update (S.fromList [1,2,3]) (S.fromList [4,5,6])
110+
111+ appendDisconnectHandler $ do
112+ conn <- ask
95− liftIO $ flip finally (atomically $ removeConnection cfg cId) $ forever $ do
113+ liftSTM $ removeConnection cfg conn
96− _ <- receiveDataMessage conn
114+
97− return ()
115+
116+ on D.subscribeWithToken $ \ (t :: Token) -> do
117+ -- emit "subscribeWithToken" $ do
118+ conn <- ask
119+ (cyc, token) <- liftIO $ atomically $ do
120+ uu <- readTVar $ updates cfg
121+ return (getFrom uu t, lastToken uu)
122+ case cyc of
123+ Nothing -> emit D.subscribeWithToken False
124+ Just uu -> do
125+ emit D.postUpdates $ TokenizedResponse token $ fold uu
126+ sId <- liftSTM $ addConnection cfg conn
127+ emit subscribeWithToken True
128+
129+ -- if validToken t then do
130+ -- conn <- ask
131+ -- liftSTM $ do
132+ -- subscribe cfg conn
133+ -- uu <- readTVar $ updates cfg
98− return ()
134+ -- return (lastToken uu)
135+
136+ -- emit "postUpdates"
137+ -- else return false
99
138
139+
140+
100liftSTM :: MonadIO m => STM a -> m a
141liftSTM :: MonadIO m => STM a -> m a
101liftSTM = liftIO . atomically
142liftSTM = liftIO . atomically
src/Network/Bacon.hsmode 100755 → 100644

Only the mode changed.

stack.yamlmode 100755 → 100644+7−2
@@ -17,7 +17,7 @@
17#
17#
18# resolver: ./custom-snapshot.yaml
18# resolver: ./custom-snapshot.yaml
19# resolver: https://example.com/snapshots/2018-01-01.yaml
19# resolver: https://example.com/snapshots/2018-01-01.yaml
20−resolver: lts-13.1
20+resolver: lts-12.25
21
21
22# User packages to be built.
22# User packages to be built.
23# Various formats can be used as shown in the example below.
23# Various formats can be used as shown in the example below.
@@ -37,7 +37,12 @@ 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+- beam-core-0.7.2.2
42+- beam-postgres-0.3.2.2
43+- socket-io-1.3.11
44+- engine-io-1.2.22
45+- engine-io-wai-1.0.9
41
46
42# Override default flag values for local packages and extra-deps
47# Override default flag values for local packages and extra-deps
43# flags: {}
48# flags: {}
swagger/Swagger.hsmode 100755 → 100644+1−1
@@ -19,6 +19,6 @@ import Data.Aeson
19import qualified Data.ByteString.Lazy as BS
19import qualified Data.ByteString.Lazy as BS
20
20
21instance ToSchema User
21instance ToSchema User
22−instance ToSchema UserName
22+-- instance ToSchema UserName
23
23
24main = return () -- BS.writeFile "swag.txt" . encode . toSwagger $ server
24main = return () -- BS.writeFile "swag.txt" . encode . toSwagger $ server
test/Spec.hsmode 100755 → 100644

Only the mode changed.