43 pipeDbConnectionLoop queries coreChan hIn hOut accountsCache = do |
44 pipeDbConnectionLoop queries coreChan hIn hOut accountsCache = do |
44 q <- readChan queries |
45 q <- readChan queries |
45 updatedCache <- case q of |
46 updatedCache <- case q of |
46 CheckAccount clUid clNick _ -> do |
47 CheckAccount clUid clNick _ -> do |
47 let cacheEntry = clNick `Map.lookup` accountsCache |
48 let cacheEntry = clNick `Map.lookup` accountsCache |
48 if isNothing cacheEntry then |
49 currentTime <- getCurrentTime |
|
50 if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 2 * 24 * 60 * 60) then |
49 do |
51 do |
50 hPutStrLn hIn $ show q |
52 hPutStrLn hIn $ show q |
51 hFlush hIn |
53 hFlush hIn |
52 |
54 |
53 (clId, accountInfo) <- hGetLine hOut >>= (maybeException . maybeRead) |
55 (clId, accountInfo) <- hGetLine hOut >>= (maybeException . maybeRead) |
54 |
56 |
55 writeChan coreChan $ ClientAccountInfo (clId, accountInfo) |
57 writeChan coreChan $ ClientAccountInfo (clId, accountInfo) |
56 |
58 |
57 return $ Map.insert clNick accountInfo accountsCache |
59 return $ Map.insert clNick (currentTime, accountInfo) accountsCache |
58 `onException` |
60 `onException` |
59 (unGetChan queries q) |
61 (unGetChan queries q) |
60 else |
62 else |
61 do |
63 do |
62 writeChan coreChan $ ClientAccountInfo (clUid, fromJust cacheEntry) |
64 writeChan coreChan $ ClientAccountInfo (clUid, snd $ fromJust cacheEntry) |
63 return accountsCache |
65 return accountsCache |
64 |
66 |
65 return updatedCache |
67 return updatedCache |
66 where |
68 where |
67 maybeException (Just a) = return a |
69 maybeException (Just a) = return a |
68 maybeException Nothing = ioError (userError "Can't read") |
70 maybeException Nothing = ioError (userError "Can't read") |
69 |
71 |
70 |
72 |
71 pipeDbConnection accountsCache serverInfo = do |
73 pipeDbConnection accountsCache serverInfo = do |
72 updatedCache <- |
74 updatedCache <- |
73 Control.Exception.handle (\e -> warningM "Database" (show e) >> return accountsCache) $ do |
75 Control.Exception.handle (\e -> warningM "Database" (show e) >> return accountsCache) $ |
74 (Just hIn, Just hOut, _, _) <- |
76 bracket |
75 createProcess (proc "./OfficialServer/extdbinterface" []) {std_in = CreatePipe, std_out = CreatePipe} |
77 (createProcess (proc "./OfficialServer/extdbinterface" []) {std_in = CreatePipe, std_out = CreatePipe}) |
76 |
78 (\(_, _, _, processHandle) -> getProcessExitCode processHandle >> return (accountsCache)) |
77 hSetBuffering hIn LineBuffering |
79 (\(Just hIn, Just hOut, _, _) -> do |
78 hSetBuffering hOut LineBuffering |
80 hSetBuffering hIn LineBuffering |
79 |
81 hSetBuffering hOut LineBuffering |
80 hPutStrLn hIn $ dbHost serverInfo |
82 |
81 hPutStrLn hIn $ dbLogin serverInfo |
83 hPutStrLn hIn $ dbHost serverInfo |
82 hPutStrLn hIn $ dbPassword serverInfo |
84 hPutStrLn hIn $ dbLogin serverInfo |
83 pipeDbConnectionLoop (dbQueries serverInfo) (coreChan serverInfo) hIn hOut accountsCache |
85 hPutStrLn hIn $ dbPassword serverInfo |
|
86 pipeDbConnectionLoop (dbQueries serverInfo) (coreChan serverInfo) hIn hOut accountsCache |
|
87 ) |
84 |
88 |
85 threadDelay (5 * 10^6) |
89 threadDelay (5 * 10^6) |
86 pipeDbConnection updatedCache serverInfo |
90 pipeDbConnection updatedCache serverInfo |
87 |
91 |
88 dbConnectionLoop = |
92 dbConnectionLoop serverInfo = |
89 if (not . null $ dbHost serverInfo) then |
93 if (not . null $ dbHost serverInfo) then |
90 pipeDbConnection Map.empty |
94 pipeDbConnection Map.empty serverInfo |
91 else |
95 else |
92 fakeDbConnection |
96 fakeDbConnection serverInfo |
93 #else |
97 #else |
94 dbConnectionLoop = fakeDbConnection |
98 dbConnectionLoop = fakeDbConnection |
95 #endif |
99 #endif |
96 |
100 |
97 startDBConnection serverInfo = |
101 startDBConnection serverInfo = |