48 writeChan (coreChan si) $ ClientAccountInfo clId clUid (if clHost `L.elem` localAddressList then Admin else Guest) |
48 writeChan (coreChan si) $ ClientAccountInfo clId clUid (if clHost `L.elem` localAddressList then Admin else Guest) |
49 ClearCache -> return () |
49 ClearCache -> return () |
50 SendStats {} -> return () |
50 SendStats {} -> return () |
51 flushRequests si |
51 flushRequests si |
52 |
52 |
53 pipeDbConnectionLoop :: Chan DBQuery -> Chan CoreMessage -> Handle -> Handle -> Map.Map ByteString (UTCTime, AccountInfo) -> IO (Map.Map ByteString (UTCTime, AccountInfo)) |
53 pipeDbConnectionLoop :: Chan DBQuery -> Chan CoreMessage -> Handle -> Handle -> Map.Map ByteString (UTCTime, AccountInfo) -> Int -> IO (Map.Map ByteString (UTCTime, AccountInfo), Int) |
54 pipeDbConnectionLoop queries cChan hIn hOut accountsCache = |
54 pipeDbConnectionLoop queries cChan hIn hOut accountsCache req = |
55 Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ |
55 Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return (accountsCache, req)) $ |
56 do |
56 do |
57 q <- readChan queries |
57 q <- readChan queries |
58 updatedCache <- case q of |
58 (updatedCache, newReq) <- case q of |
59 CheckAccount clId clUid clNick _ -> do |
59 CheckAccount clId clUid clNick _ -> do |
60 let cacheEntry = clNick `Map.lookup` accountsCache |
60 let cacheEntry = clNick `Map.lookup` accountsCache |
61 currentTime <- getCurrentTime |
61 currentTime <- getCurrentTime |
62 if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 2 * 24 * 60 * 60) then |
62 if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 2 * 24 * 60 * 60) then |
63 do |
63 do |
66 |
66 |
67 (clId', clUid', accountInfo) <- SIO.hGetLine hOut >>= (maybeException . maybeRead) |
67 (clId', clUid', accountInfo) <- SIO.hGetLine hOut >>= (maybeException . maybeRead) |
68 |
68 |
69 writeChan cChan $ ClientAccountInfo clId' clUid' accountInfo |
69 writeChan cChan $ ClientAccountInfo clId' clUid' accountInfo |
70 |
70 |
71 return $ Map.insert clNick (currentTime, accountInfo) accountsCache |
71 return $ (Map.insert clNick (currentTime, accountInfo) accountsCache, req + 1) |
72 `Exception.onException` |
72 `Exception.onException` |
73 (unGetChan queries q |
73 (unGetChan queries q) |
74 >> writeChan cChan (ClientAccountInfo clId clUid Guest) |
|
75 ) |
|
76 else |
74 else |
77 do |
75 do |
78 writeChan cChan $ ClientAccountInfo clId clUid (snd $ fromJust cacheEntry) |
76 writeChan cChan $ ClientAccountInfo clId clUid (snd $ fromJust cacheEntry) |
79 return accountsCache |
77 return (accountsCache, req) |
80 |
78 |
81 ClearCache -> return Map.empty |
79 ClearCache -> return (Map.empty, req) |
82 SendStats {} -> ( |
80 SendStats {} -> ( |
83 (SIO.hPutStrLn hIn $ show q) >> |
81 (SIO.hPutStrLn hIn $ show q) >> |
84 hFlush hIn >> |
82 hFlush hIn >> |
85 return accountsCache) |
83 return (accountsCache, req)) |
86 `Exception.onException` |
84 `Exception.onException` |
87 (unGetChan queries q) |
85 (unGetChan queries q) |
88 |
86 |
89 pipeDbConnectionLoop queries cChan hIn hOut updatedCache |
87 pipeDbConnectionLoop queries cChan hIn hOut updatedCache newReq |
90 where |
88 where |
91 maybeException (Just a) = return a |
89 maybeException (Just a) = return a |
92 maybeException Nothing = ioError (userError "Can't read") |
90 maybeException Nothing = ioError (userError "Can't read") |
93 |
91 |
94 pipeDbConnection :: forall b. Map.Map ByteString (UTCTime, AccountInfo) -> ServerInfo -> Int -> IO b |
92 pipeDbConnection :: forall b. Map.Map ByteString (UTCTime, AccountInfo) -> ServerInfo -> Int -> IO b |
102 hSetBuffering hOut LineBuffering |
100 hSetBuffering hOut LineBuffering |
103 |
101 |
104 B.hPutStrLn hIn $ dbHost si |
102 B.hPutStrLn hIn $ dbHost si |
105 B.hPutStrLn hIn $ dbLogin si |
103 B.hPutStrLn hIn $ dbLogin si |
106 B.hPutStrLn hIn $ dbPassword si |
104 B.hPutStrLn hIn $ dbPassword si |
107 c <- pipeDbConnectionLoop (dbQueries si) (coreChan si) hIn hOut accountsCache |
105 (c, r) <- pipeDbConnectionLoop (dbQueries si) (coreChan si) hIn hOut accountsCache 0 |
108 return (c, 0) |
106 return (c, if r > 0 then 0 else errNum + 1) |
109 |
107 |
110 when (newErrNum > 1) $ flushRequests si |
108 when (newErrNum > 1) $ flushRequests si |
111 threadDelay (3000000) |
109 threadDelay (3000000) |
112 pipeDbConnection updatedCache si newErrNum |
110 pipeDbConnection updatedCache si newErrNum |
113 |
111 |