40 throw (e :: Exception) -- |
40 throw (e :: Exception) -- |
41 -- to be deleted -------------------------------------------------- |
41 -- to be deleted -------------------------------------------------- |
42 ------------------------------------------------------------------- |
42 ------------------------------------------------------------------- |
43 |
43 |
44 |
44 |
45 pipeDbConnectionLoop queries coreChan hIn hOut accountsCache = do |
45 pipeDbConnectionLoop queries coreChan hIn hOut accountsCache = |
|
46 Control.Exception.handle (\e -> warningM "Database" (show e) >> return accountsCache) $ |
|
47 do |
46 q <- readChan queries |
48 q <- readChan queries |
47 updatedCache <- case q of |
49 updatedCache <- case q of |
48 CheckAccount clUid clNick _ -> do |
50 CheckAccount clUid clNick _ -> do |
49 let cacheEntry = clNick `Map.lookup` accountsCache |
51 let cacheEntry = clNick `Map.lookup` accountsCache |
50 currentTime <- getCurrentTime |
52 currentTime <- getCurrentTime |
64 do |
66 do |
65 writeChan coreChan $ ClientAccountInfo (clUid, snd $ fromJust cacheEntry) |
67 writeChan coreChan $ ClientAccountInfo (clUid, snd $ fromJust cacheEntry) |
66 return accountsCache |
68 return accountsCache |
67 |
69 |
68 ClearCache -> return Map.empty |
70 ClearCache -> return Map.empty |
69 SendStats {} -> do |
71 SendStats {} -> onException ( |
70 hPutStrLn hIn $ show q |
72 (hPutStrLn hIn $ show q) >> |
71 hFlush hIn |
73 hFlush hIn >> |
72 return accountsCache |
74 return accountsCache) |
73 |
75 (unGetChan queries q) |
74 return updatedCache |
76 |
|
77 pipeDbConnectionLoop queries coreChan hIn hOut updatedCache |
75 where |
78 where |
76 maybeException (Just a) = return a |
79 maybeException (Just a) = return a |
77 maybeException Nothing = ioError (userError "Can't read") |
80 maybeException Nothing = ioError (userError "Can't read") |
78 |
81 |
79 |
82 |
80 pipeDbConnection accountsCache serverInfo = do |
83 pipeDbConnection accountsCache serverInfo = do |
81 updatedCache <- |
84 updatedCache <- |
82 Control.Exception.handle (\e -> warningM "Database" (show e) >> return accountsCache) $ |
85 Control.Exception.handle (\e -> warningM "Database" (show e) >> return accountsCache) $ do |
83 bracket |
86 (Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" []) |
84 (createProcess (proc "./OfficialServer/extdbinterface" []) {std_in = CreatePipe, std_out = CreatePipe}) |
87 {std_in = CreatePipe, |
85 (\(_, _, _, processHandle) -> return accountsCache) |
88 std_out = CreatePipe} |
86 (\(Just hIn, Just hOut, _, _) -> do |
89 hSetBuffering hIn LineBuffering |
87 hSetBuffering hIn LineBuffering |
90 hSetBuffering hOut LineBuffering |
88 hSetBuffering hOut LineBuffering |
|
89 |
|
90 hPutStrLn hIn $ dbHost serverInfo |
|
91 hPutStrLn hIn $ dbLogin serverInfo |
|
92 hPutStrLn hIn $ dbPassword serverInfo |
|
93 pipeDbConnectionLoop (dbQueries serverInfo) (coreChan serverInfo) hIn hOut accountsCache |
|
94 ) |
|
95 |
91 |
96 threadDelay (5 * 10^6) |
92 hPutStrLn hIn $ dbHost serverInfo |
|
93 hPutStrLn hIn $ dbLogin serverInfo |
|
94 hPutStrLn hIn $ dbPassword serverInfo |
|
95 pipeDbConnectionLoop (dbQueries serverInfo) (coreChan serverInfo) hIn hOut accountsCache |
|
96 |
|
97 threadDelay (3 * 10^6) |
97 pipeDbConnection updatedCache serverInfo |
98 pipeDbConnection updatedCache serverInfo |
98 |
99 |
99 dbConnectionLoop serverInfo = |
100 dbConnectionLoop serverInfo = |
100 if (not . null $ dbHost serverInfo) then |
101 if (not . null $ dbHost serverInfo) then |
101 pipeDbConnection Map.empty serverInfo |
102 pipeDbConnection Map.empty serverInfo |