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