Skip to content
Newer
Older
100644 161 lines (129 sloc) 4.55 KB
a68f0c9 @basvandijk Initial import of bank.hs
authored
1 {-# LANGUAGE TupleSections #-}
2
3 module Main where
4
5 import Control.Concurrent
6 import Control.Concurrent.STM
7 import Control.Exception
8 import Control.Monad
9 import Data.Functor
10 import Data.IORef
11 import Data.List
12 import Data.Map ( Map )
13 import qualified Data.Map as M
14 import Data.Maybe
15 import Network
16 import Network.Socket (close)
17 import System.IO
18 import Text.Printf
19
20 type Bank = TVar State
21
22 data State = State { credit :: Map Account (TVar CHF) }
23
24 type Account = Int
25 type CHF = Int
26
27 port :: PortNumber
28 port = 9876
29
30 main :: IO ()
31 main = withSocketsDo $ do
32 putStrLn $ printf "Listening on port: %s..." (show port)
33 s <- listenOn $ PortNumber port
34 bank <- atomically $ newTVar $ State {credit = M.empty}
35
36 forever $ do
37 c@(h, _, _) <- accept s
38 void $ forkFinally (handleRequest (handleSession bank) c) $ \e -> do
39 case e of
40 Left ex -> putStrLn $ "Exception: " ++ show ex
41 Right _ -> return ()
42 hClose h
43
44 handleRequest :: ([String] -> IO String)
45 -> (Handle, HostName, PortNumber)
46 -> IO ()
47 handleRequest handleSession (h, hostname, port) = do
48 putStrLn $ printf "Accepting connection from: %s on port: %s"
49 hostname (show port)
50 hSetBuffering h LineBuffering
51 loop
52 where
53 loop = do
54 req <- hGetLine h
55 let command = words req
56 if command == ["CLOSE"]
57 then return ()
58 else do
59 (handleSession command >>= hPutStrLn h) `catch` \e ->
60 hPutStrLn h $ "Exception: " ++ show (e :: SomeException)
61 loop
62
63 showAccounts :: Map Account (TVar CHF) -> STM String
64 showAccounts m = intercalate "\n" <$> mapM showAccount (M.toList m)
65
66 showAccount :: (Account, TVar CHF) -> STM String
67 showAccount (account, chfTVar) = (show . (account,)) <$> readTVar chfTVar
68
69 look k m = maybe (err "not found") return $ M.lookup k m
70
71 err :: String -> STM a
72 err = throwSTM . ErrorCall
73
74 handleSession :: Bank -> [String] -> IO String
75 handleSession bank ["LIST"] = atomically $ do
76 st <- readTVar bank
77 creditStr <- showAccounts $ credit st
78 return creditStr
79
80 handleSession bank ["CREATE", accountStr, chfStr] = atomically $ do
81 let account = read accountStr
82 chf = read chfStr
83 st <- readTVar bank
84 when (account `M.member` credit st) $
85 error $ "Credit account already exists!"
86 chfTVar <- newTVar chf
87 let st' = st {credit = M.insert account chfTVar $ credit st}
88 writeTVar bank st'
89 return "Credit account created."
90
91 handleSession bank ["CREDIT", accountStr, deltaStr] = atomically $ do
92 let account = read accountStr
93 delta = read deltaStr
94 st <- readTVar bank
95 chfTVar <- look account $ credit st
96 chf <- readTVar chfTVar
97 let chf' = chf + delta
98 when (chf' < 0) $
99 err $ printf "Can't have negative amount of: %i" chf'
100 writeTVar chfTVar chf'
101 return "Account credited."
102
103 handleSession bank ["CREDIT_BLOCK", accountStr, deltaStr] = atomically $ do
104 let account = read accountStr
105 delta = read deltaStr
106 st <- readTVar bank
107 creditAccount account delta st
108
109 handleSession bank ["CREDIT_ONEOF", account1Str, account2Str, deltaStr] = atomically $ do
110 let account1 = read account1Str
111 account2 = read account2Str
112 delta = read deltaStr
113 st <- readTVar bank
114
115 creditAccount account1 delta st
116 `orElse`
117 creditAccount account2 delta st
118
119 handleSession bank ["TRANSFER", fromAccountStr, toAccountStr, deltaStr] = atomically $ do
120 let fromAccount = read fromAccountStr
121 toAccount = read toAccountStr
122 delta = read deltaStr
123 st <- readTVar bank
124
125 fromChfTVar <- look fromAccount $ credit st
126 toChfTVar <- look toAccount $ credit st
127
128 fromChf <- readTVar fromChfTVar
129 toChf <- readTVar toChfTVar
130
131 let fromChf' = fromChf - delta
132 toChf' = toChf + delta
133
134 when (fromChf' < 0) $
135 err $ printf "Can't have negative amount of %i in from account" fromChf'
136
137 when (toChf' < 0) $
138 err $ printf "Can't have negative amount of %i in to account" toChf'
139
140 return $! fib 40
141
142 writeTVar fromChfTVar fromChf'
143 writeTVar toChfTVar toChf'
144
145 return "Transfer complete."
146
147 handleSession _ _ = return "Unknown command!"
148
149 fib 0 = 0
150 fib 1 = 1
151 fib n = fib (n-1) + fib (n-2)
152
153 creditAccount :: Account -> CHF -> State -> STM String
154 creditAccount account delta st = do
155 chfTVar <- look account $ credit st
156 chf <- readTVar chfTVar
157 let chf' = chf + delta
158 when (chf' < 0) retry
159 writeTVar chfTVar chf'
160 return "Account credited."
Something went wrong with that request. Please try again.