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

Only the mode changed.

Procfilemode 100644 → 100755

Only the mode changed.

Setup.hsmode 100644 → 100755

Only the mode changed.

app.jsonmode 100644 → 100755

Only the mode changed.

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

Only the mode changed.

docs/Docs.hsmode 100644 → 100755+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 = return () -- writeFile "docs.md" . markdown . docs . pretty $ server
22+main = 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 100644 → 100755−7
@@ -37,13 +37,6 @@ 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
47
40
48library:
41library:
49 source-dirs: src
42 source-dirs: src
readme.mdmode 100644 → 100755+101−87
@@ -6,9 +6,64 @@ _url: [`https://websuck1t.herokuapp.com`](https://websuck1t.herokuapp.com)_
6
6
7## GET /posts/all
7## GET /posts/all
8
8
9−_start with: [`https://websuck1t.herokuapp.com/posts/all`](https://websuck1t.herokuapp.com/posts/all)_
9+### Response:
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`.
10
63
11−Use this _url_ to get the token every time when application begins and previous session was closed
64+### Captures:
65+
66+- *id*: The id of the entity you want to query.
12
67
13### Response:
68### Response:
14
69
@@ -23,41 +78,64 @@ Use this _url_ to get the token every time when application begins and previous
23
78
24```javascript
79```javascript
25{
80{
26− "token": 1828,
81+ "userName": {
27− "response": {
82+ "secondName": "Leonidovich",
28− "deleted": [],
83+ "firstName": "Seva"
29− "added": [
30− 1844,
31− 1845,
32− 1846
33− ]
34− }
84+ },
85+ "userId": 1
35}
86}
87+```
88+
89+- Example (`application/json`):
36
90
91+```javascript
92+{
93+ "userName": {
94+ "secondName": "Barovich",
95+ "firstName": "Foo"
96+ },
97+ "userId": 42
98+}
37```
99```
38
100
39−### Response fields
101+- Example (`application/json`):
40
102
41−- "token" to further use it in subscription to web socket
103+```javascript
42−- "response" to start with the given number of posts in table
104+{
105+ "userName": {
106+ "secondName": "Fooovich",
107+ "firstName": "Bar"
108+ },
109+ "userId": 69
110+}
111+```
43
112
44−## socket.io /posts/subscribe/
113+- Example (`application/json`):
45
114
46−_NOTE: subscribe to the `"postUpdates"` event before submitting the token to `"subscribeWithToken"`._
115+```javascript
116+{
117+ "userName": {
118+ "secondName": "Quixovich",
119+ "firstName": "Qux"
120+ },
121+ "userId": 8
122+}
123+```
47
124
48−You access the web socket with the socket io protocol. You will most likely need to install a library.
125+## WebSocket /posts/subscribe/:token
49
126
50−### Connecting
127+You access the web socket with the web socket protocol. I. e. `https://` -> `ws://`.
51
128
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.
129+Open a web socket from the given `token` for receiving events about new and deleted posts.
53
130
54−#### Response
131+#### Returns error `498` if the supplied token has expired or is invalid.
55
132
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.
57
133
58−### Receiving updates
134+### Captures:
135+
136+- *token*: The token, received with the previous request.
59
137
60−Updates will be sent to you on the `"postUpdates"` event. The event message will contain the following JSON Object (same as `/posts/all`):
138+### Response:
61
139
62```javascript
140```javascript
63{
141{
@@ -79,8 +157,6 @@ Updates will be sent to you on the `"postUpdates"` event. The event message will
79
157
80## GET /posts/:id
158## GET /posts/:id
81
159
82−_url: [`https://websuck1t.herokuapp.com/posts/{id}`](https://websuck1t.herokuapp.com/posts/1)_
83−
84#### If there is no post with the given `id`, the method returns error `404`.
160#### If there is no post with the given `id`, the method returns error `404`.
85
161
86### Captures:
162### Captures:
@@ -145,65 +221,3 @@ _url: [`https://websuck1t.herokuapp.com/posts/{id}`](https://websuck1t.herokuapp
145 "postId": 1
221 "postId": 1
146}
222}
147```
223```
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 100644 → 100755

Only the mode changed.

src/Data/Error.hsmode 100644 → 100755

Only the mode changed.

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

Only the mode changed.

stack.yamlmode 100644 → 100755+2−7
@@ -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-12.25
20+resolver: lts-13.1
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,12 +37,7 @@ 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
46
41
47# Override default flag values for local packages and extra-deps
42# Override default flag values for local packages and extra-deps
48# flags: {}
43# flags: {}
swagger/Swagger.hsmode 100644 → 100755+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 100644 → 100755

Only the mode changed.