/src/Models/Connection.hs
Haskell | 90 lines | 61 code | 19 blank | 10 comment | 0 complexity | 394103af9c171c46281f4aad5f4eb268 MD5 | raw file
1{-# LANGUAGE OverloadedStrings #-} 2module Models.Connection where 3 4import Prelude hiding (lookup) 5 6import Data.Time.Clock (UTCTime, getCurrentTime) 7import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime) 8import Data.UString (UString) 9 10import DB 11 12-- |An eventSource connection to the broker persisted in mongoDB 13data Connection = Connection 14 { socketId :: UString 15 , brokerId :: UString 16 , userId :: UString 17 , channel :: UString 18 , presenceId :: Maybe UString 19 , disconnectAt :: Maybe Int -- Seconds from current time 20 } 21 22-- |Store a "connection" to the broker in the database 23-- If the disconnect is set, the connection will be marked for 24-- disconnection during a coming sweep 25store :: DB -> Connection -> IO (Either Failure ()) 26store db conn= do 27 time <- disconnectTime (disconnectAt conn) 28 run db $ repsert (select s "connections") (d time) 29 where 30 s = ["_id" =: socketId conn, "channel" =: channel conn, "user_id" =: userId conn] 31 d (Just time) = s ++ presence ++ ["broker" =: brokerId conn, "disconnect_at" =: time] 32 d Nothing = s ++ presence ++ ["broker" =: brokerId conn] 33 presence = case presenceId conn of 34 Just pid -> ["presence_id" =: pid] 35 Nothing -> [] 36 37 38-- |Mark a connection. Marked connections will be removed by a later 39-- sweep 40mark :: DB -> Connection -> IO (Either Failure ()) 41mark db conn = do 42 case disconnectAt conn of 43 Just offset -> do 44 time <- disconnectTime (Just offset) 45 run db $ modify (select s "connections") (m time) 46 Nothing -> return $ Right () 47 where 48 s = ["_id" =: (socketId conn), "user_id" =: userId conn] 49 m time = ["$set" =: ["disconnect_at" =: time]] 50 51 52-- |Sweep connections. All marked connections with a disconnect_at less 53-- than the current time will be removed. 54sweep :: DB -> UString -> IO (Either Failure ()) 55sweep db bid = do 56 time <- getCurrentTime 57 run db $ delete (select ["broker" =: bid, "disconnect_at" =: ["$lte" =: time]] "connections") 58 59 60-- |Remove all connections from a broker from the db 61remove :: DB -> UString -> IO (Either Failure ()) 62remove db bid = 63 run db $ delete (select ["broker" =: bid] "connections") 64 65 66get :: DB -> UString -> IO (Either Failure (Maybe Connection)) 67get db sid = do 68 result <- run db $ findOne (select ["_id" =: sid] "connections") 69 return $ returnModel constructor result 70 71 72constructor :: Document -> Connection 73constructor doc = Connection { 74 brokerId = at "broker" doc 75 , socketId = at "_id" doc 76 , userId = at "user_id" doc 77 , channel = at "channel" doc 78 , presenceId = lookup "presence_id" doc 79 , disconnectAt = Nothing 80 } 81 82 83count :: DB -> UString -> IO (Either Failure Int) 84count db bid = 85 run db $ DB.count (select ["broker" =: bid] "connections") 86 87 88disconnectTime :: Maybe Int -> IO (Maybe UTCTime) 89disconnectTime (Just offset) = fmap (Just . posixSecondsToUTCTime . (+ (fromIntegral offset))) getPOSIXTime 90disconnectTime Nothing = return Nothing