@@ -1,5 +1,12 @@
11{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GADTs #-}
23{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeApplications #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+
310
411module Foo.Data
512 (
@@ -9,7 +16,6 @@ module Foo.Data
916 createApp,
1017 createConfig,
1118 User(..),
12− UserName(..),
1319 Config,
1420 updates,
1521 allUsers,
@@ -50,6 +56,12 @@ import qualified Data.CyclicBuffer as CB
5056import Data.Set ((\\), union)
5157import Data.Monoid
5258import 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
5365
5466type App = ReaderT Config Handler
5567
@@ -57,35 +69,35 @@ class HasConfig c where
5769 getCfg :: c -> Config
5870
5971allUsers :: App [User]
60−allUsers = ask >>= liftIO . fmap M.elems . readTVarIO . users
72+allUsers = asks dbConn >>= \conn -> liftIO . P.runBeamPostgres conn . runSelectReturningList . select . all_ . users $ socialDb
6173
6274post :: PostId -> App Post
6375post pId = do
64− cfg <- ask
65− u <- liftIO . atomically . fmap (M.lookup pId) . readTVar . posts $ cfg
76+ conn <- asks dbConn
77+ u <- liftIO . P.runBeamPostgres conn . runSelectReturningOne . flip lookup_ (PostId pId) . posts $ socialDb
6678 case u of
6779 Just u -> return u
6880 Nothing -> throwError err404
6981
7082user :: UserId -> App User
7183user uId = do
72− cfg <- ask
73− u <- liftIO . atomically . fmap (M.lookup uId) . readTVar . users $ cfg
84+ conn <- asks dbConn
85+ u <- liftIO . P.runBeamPostgres conn . runSelectReturningOne . flip lookup_ (UserId uId) . users $ socialDb
7486 case u of
7587 Just u -> return u
7688 Nothing -> throwError err404
7789
78−allPosts :: App (STM [Post])
79−allPosts = asks $ fmap M.elems . readTVar . posts
90+allPosts :: App [Post]
91+allPosts = asks dbConn >>= \conn -> liftIO . P.runBeamPostgres conn . runSelectReturningList . select . all_ . posts $ socialDb
8092
8193getToken :: App (STM Token)
8294getToken = asks $ fmap CB.lastToken . readTVar . updates
8395
84−createConfig :: IO Config
85−createConfig = do
96+createConfig :: P.Connection -> IO Config
97+createConfig conn = do
8698 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)
88− forkIO . forever $ threadDelay 7000000 >> (runHandler . createApp cfg $ startAddingPosts 20 cfg >>= uncurry sendUpdate)
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)
89101 return cfg
90102
91103type Token = Int
@@ -139,10 +151,7 @@ type PostId = Int
139151type ConnectionId = Int
140152
141153data Config = Config {
142− lastUserID :: TVar UserId,
143− lastPostID :: TVar PostId,
144− users :: TVar (M.Map Int User),
145− posts :: TVar (M.Map Int Post),
154+ dbConn :: P.Connection,
146155 manager :: Manager,
147156 connections :: TVar (M.Map ConnectionId Connection),
148157 lastConnection :: TVar ConnectionId,
@@ -152,42 +161,56 @@ data Config = Config {
152161instance HasConfig Config where
153162 getCfg = id
154163
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−
162164startAddingPosts :: Int -> Config -> App (Token, Update)
163165startAddingPosts lim cfg = do
164166 cfg <- ask
165− let us = users cfg
166− let ps = posts cfg
167+ let conn = dbConn cfg
168+ -- let us = users socialDb
169+ -- let ps = posts socialDb
167170
168171 a <- liftIO $ loremBacon (manager cfg) (Just AllMeat) (Just lim) (Just 0)
169172 g <- liftIO newStdGen
170173 let rns = randoms g
171−
174+
172175 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)
176+
177+ let deleteCount = 3
178+
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)
191214
192215sendUpdate :: Token -> Update -> App ()
193216sendUpdate t u = do
@@ -196,50 +219,84 @@ sendUpdate t u = do
196219 liftIO $ forM conns $ flip sendTextData $ encode $ TokenizedResponse t u
197220 return ()
198221
222+modIndex :: [a] -> Int -> a
223+modIndex aa i = aa !! (i `mod` length aa)
224+
225+infixl 5 %!
226+(%!) = modIndex
227+
228+
199229randomFrom :: Int -> M.Map k v -> k
200230randomFrom g as = M.keys as !! (abs g `mod` M.size as)
201231
202−newUser :: Config -> Text -> Text -> STM User
232+newUser :: Config -> Text -> Text -> IO [User]
203233newUser cfg first second = do
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
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
228253} deriving Generic
229254
230−data Post = Post {
231− postId :: PostId,
232− postAuthor :: UserId,
233− postBody :: Text
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
234271} deriving Generic
235272
273+instance Beamable PostT
274+
275+type Post = PostT Identity
276+
236277instance ToJSON User
237278instance ToJSON Post
238279
239−data UserName = UserName {
240− firstName :: Text,
241− secondName :: Text
242−} deriving (Generic)
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
243292
244−instance ToJSON UserName
293+instance Database be SocialDb
245294
295+socialDb :: DatabaseSettings be SocialDb
296+socialDb = defaultDbSettings `withDbModification`
297+ dbModification {
298+ users = modifyTable id $ tableModification {
299+ firstName = "firstname",
300+ secondName = "secondname"
301+ }
302+ }