/src/Models/Connection.hs

 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