@@ -1,12 +1,5 @@
11{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE GADTs #-}
32{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE TypeApplications #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−
103
114module Foo.Data
125 (
@@ -16,6 +9,7 @@ module Foo.Data
169 createApp,
1710 createConfig,
1811 User(..),
12+ UserName(..),
1913 Config,
2014 updates,
2115 allUsers,
@@ -56,12 +50,6 @@ import qualified Data.CyclicBuffer as CB
5650import Data.Set ((\\), union)
5751import Data.Monoid
5852import Debug.Trace
59−import Database.Beam
60−import qualified Database.Beam.Postgres as P
61−import Database.Beam.Query
62−import Database.PostgreSQL.Simple (withTransaction)
63−import Database.Beam.Backend.SQL.BeamExtensions
64−import System.Random.Shuffle
6553
6654type App = ReaderT Config Handler
6755
@@ -69,35 +57,35 @@ class HasConfig c where
6957 getCfg :: c -> Config
7058
7159allUsers :: App [User]
72−allUsers = asks dbConn >>= \conn -> liftIO . P.runBeamPostgres conn . runSelectReturningList . select . all_ . users $ socialDb
60+allUsers = ask >>= liftIO . fmap M.elems . readTVarIO . users
7361
7462post :: PostId -> App Post
7563post pId = do
76− conn <- asks dbConn
77− u <- liftIO . P.runBeamPostgres conn . runSelectReturningOne . flip lookup_ (PostId pId) . posts $ socialDb
64+ cfg <- ask
65+ u <- liftIO . atomically . fmap (M.lookup pId) . readTVar . posts $ cfg
7866 case u of
7967 Just u -> return u
8068 Nothing -> throwError err404
8169
8270user :: UserId -> App User
8371user uId = do
84− conn <- asks dbConn
85− u <- liftIO . P.runBeamPostgres conn . runSelectReturningOne . flip lookup_ (UserId uId) . users $ socialDb
72+ cfg <- ask
73+ u <- liftIO . atomically . fmap (M.lookup uId) . readTVar . users $ cfg
8674 case u of
8775 Just u -> return u
8876 Nothing -> throwError err404
8977
90−allPosts :: App [Post]
91−allPosts = asks dbConn >>= \conn -> liftIO . P.runBeamPostgres conn . runSelectReturningList . select . all_ . posts $ socialDb
78+allPosts :: App (STM [Post])
79+allPosts = asks $ fmap M.elems . readTVar . posts
9280
9381getToken :: App (STM Token)
9482getToken = asks $ fmap CB.lastToken . readTVar . updates
9583
96−createConfig :: P.Connection -> IO Config
97−createConfig conn = do
84+createConfig :: IO Config
85+createConfig = do
9886 mng <- newManager tlsManagerSettings
99− cfg <- atomically $ Config <$> return conn <*> return mng <*> newTVar M.empty <*> newTVar 0 <*> newTVar (CB.empty 20)
100− forkIO . forever $ threadDelay 7000000 >> (runHandler . createApp cfg $ startAddingPosts 25 cfg >>= uncurry sendUpdate)
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)
88+ forkIO . forever $ threadDelay 2000000 >> (runHandler . createApp cfg $ startAddingPosts 20 cfg >>= uncurry sendUpdate)
10189 return cfg
10290
10391type Token = Int
@@ -151,7 +139,10 @@ type PostId = Int
151139type ConnectionId = Int
152140
153141data Config = Config {
154− 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),
155146 manager :: Manager,
156147 connections :: TVar (M.Map ConnectionId Connection),
157148 lastConnection :: TVar ConnectionId,
@@ -161,56 +152,42 @@ data Config = Config {
161152instance HasConfig Config where
162153 getCfg = id
163154
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+
164162startAddingPosts :: Int -> Config -> App (Token, Update)
165163startAddingPosts lim cfg = do
166164 cfg <- ask
167− let conn = dbConn cfg
168− -- let us = users socialDb
169− -- let ps = posts socialDb
165+ let us = users cfg
166+ let ps = posts cfg
170167
171168 a <- liftIO $ loremBacon (manager cfg) (Just AllMeat) (Just lim) (Just 0)
172169 g <- liftIO newStdGen
173170 let rns = randoms g
174−
175− let t = fromMaybe (repeat "None") a
176−
177− let deleteCount = 3
178171
179− (deletedIds, addedIds) <- join . liftIO . withTransaction conn . return $ do
180− userIds <- liftIO . P.runBeamPostgres conn . runSelectReturningList . select $ do
181− uc <- all_ . users $ socialDb
182− pure (userId uc)
183−
184− if length userIds <= 0 then return ([],[])
185− else do
186− postIds <- liftIO . P.runBeamPostgres conn . runSelectReturningList . select $ do
187− uc <- all_ . posts $ socialDb
188− pure (postId uc)
189−
190−
191− let postCount = length postIds
192− let toDeleteIndecies = take deleteCount $ shuffle' postIds postCount g
193−
194− let toAdd = max 0 $ lim - length postIds + length toDeleteIndecies
195−
196− -- Just deletedPost <- liftIO . P.runBeamPostgres conn . runSelectReturningOne . select . limit_ 1 . offset_ (fromIntegral $ toDeleteIndex - 1) . all_ . posts $ socialDb
197− -- let deletedId = postId deletedPost
198−
199− unless (length toDeleteIndecies <= 0) $
200− liftIO . P.runBeamPostgres conn . runDelete $
201− delete (posts socialDb) ((`in_` map val_ toDeleteIndecies) . postId)
202−
203− 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)
204−
205− return (toDeleteIndecies, map postId nIds)
206−
207− liftIO . atomically $ do
208− let upd = Update (S.fromList addedIds) (S.fromList deletedIds)
209− let uppT = updates cfg
210− upp <- readTVar uppT
211− let (token, upp') = CB.insert upp upd
212− writeTVar uppT upp'
213− return (token, upd)
172+ let t = fromMaybe (repeat "None") a
173+ liftIO . atomically $ do
174+ uu <- readTVar us
175+ let uSize = M.size uu
176+ if uSize >= 1 then do
177+ pp <- readTVar ps
178+ let toDeleteIndex = head rns `mod` M.size pp
179+ let deletedKey = fst $ M.elemAt toDeleteIndex pp
180+ dd <- if M.size pp > 0 then writeTVar ps (M.deleteAt toDeleteIndex pp) >> return [deletedKey]
181+ else return []
182+ let toAdd = max 0 $ lim - (M.size pp - 1)
183+ add <- fmap (map postId) $ forM (zip rns $ take toAdd t) $ \(rnd, t) -> newPost cfg (randomFrom rnd uu) t
184+ let upd = Update (S.fromList add) (S.fromList dd)
185+ let uppT = updates cfg
186+ upp <- readTVar uppT
187+ let (token, upp') = CB.insert upp upd
188+ writeTVar uppT upp'
189+ return (token, upd)
190+ else return (0, mempty)
214191
215192sendUpdate :: Token -> Update -> App ()
216193sendUpdate t u = do
@@ -219,84 +196,50 @@ sendUpdate t u = do
219196 liftIO $ forM conns $ flip sendTextData $ encode $ TokenizedResponse t u
220197 return ()
221198
222−modIndex :: [a] -> Int -> a
223−modIndex aa i = aa !! (i `mod` length aa)
224−
225−infixl 5 %!
226−(%!) = modIndex
227−
228−
229199randomFrom :: Int -> M.Map k v -> k
230200randomFrom g as = M.keys as !! (abs g `mod` M.size as)
231201
232−newUser :: Config -> Text -> Text -> IO [User]
202+newUser :: Config -> Text -> Text -> STM User
233203newUser cfg first second = do
234− let conn = dbConn cfg
235− P.runBeamPostgres conn . runInsertReturningList (users socialDb) $ insertExpressions [User default_ (val_ first) (val_ second)]
236−
237−
238−-- newPost :: Config -> UserId -> Text -> STM Post
239−-- newPost cfg user body = do
240−-- let lastId = lastPostID cfg
241−-- let ps = posts cfg
242−-- do
243−-- id <- readTVar lastId
244−-- writeTVar lastId (id+1)
245−-- let p = Post id user body
246−-- modifyTVar ps $ M.insert id p
247−-- return p
248−
249−data UserT f = User {
250− userId :: Columnar f UserId,
251− firstName :: Columnar f Text,
252− secondName :: Columnar f Text
204+ let lastID = lastUserID cfg
205+ let us = users cfg
206+ do
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+
214+newPost :: Config -> UserId -> Text -> STM Post
215+newPost cfg user body = do
216+ let lastId = lastPostID cfg
217+ let ps = posts cfg
218+ do
219+ id <- readTVar lastId
220+ writeTVar lastId (id+1)
221+ let p = Post id user body
222+ modifyTVar ps $ M.insert id p
223+ return p
224+
225+data User = User {
226+ userName :: UserName,
227+ userId :: UserId
253228} deriving Generic
254229
255−instance Beamable UserT
256−
257−type User = UserT Identity
258−
259−instance Table UserT where
260− data PrimaryKey UserT f = UserId (Columnar f UserId)
261− deriving Generic
262−
263− primaryKey = UserId . userId
264−
265−instance Beamable (PrimaryKey UserT)
266−
267−data PostT f = Post {
268− postId :: Columnar f PostId,
269− postAuthor :: Columnar f UserId,
270− postBody :: Columnar f Text
230+data Post = Post {
231+ postId :: PostId,
232+ postAuthor :: UserId,
233+ postBody :: Text
271234} deriving Generic
272235
273−instance Beamable PostT
274−
275−type Post = PostT Identity
276−
277236instance ToJSON User
278237instance ToJSON Post
279238
280−instance Table PostT where
281− data PrimaryKey PostT f = PostId (Columnar f PostId)
282− deriving Generic
283−
284− primaryKey = PostId . postId
285−
286−instance Beamable (PrimaryKey PostT)
287−
288−data SocialDb f = SocialDb {
289− users :: f (TableEntity UserT),
290− posts :: f (TableEntity PostT)
291−} deriving Generic
239+data UserName = UserName {
240+ firstName :: Text,
241+ secondName :: Text
242+} deriving (Generic)
292243
293−instance Database be SocialDb
244+instance ToJSON UserName
294245
295−socialDb :: DatabaseSettings be SocialDb
296−socialDb = defaultDbSettings `withDbModification`
297− dbModification {
298− users = modifyTable id $ tableModification {
299− firstName = "firstname",
300− secondName = "secondname"
301− }
302− }