-
Notifications
You must be signed in to change notification settings - Fork 5
/
Copy pathMySQLConnector.hs
215 lines (180 loc) · 10.3 KB
/
MySQLConnector.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-| Author: Pablo Perez Garcia
Connector working in top of library MySQL-Haskell https://github.com/winterland1989/mysql-haskell
The version of MySQL-Haskell 0.8.3.0 only works properly with MySQL server 5.5-}
module MySQLConnector where
import Database.MySQL.Base
import qualified System.IO.Streams as Streams
import Data.Int
import ModelTypes
import qualified Data.Text as T
import Data.List
import Control.Monad.IO.Class
import System.IO.Streams (InputStream)
import Control.Concurrent (myThreadId,newEmptyMVar,forkIO,threadDelay,putMVar,takeMVar)
selectAllQuery = "SELECT * FROM haskell_users"
selectByIdQuery = "SELECT * FROM haskell_users WHERE userId=(?)"
selectByNameQuery = "SELECT * FROM haskell_users WHERE userName=(?)"
deleteByIdQuery = "DELETE FROM haskell_users WHERE userId=(?)"
insertUserQuery = "INSERT INTO mysql.haskell_users (userId,userName) VALUES(?,?)"
updateUserQuery = "UPDATE mysql.haskell_users SET userId=(?),userName=(?) WHERE userId=(?)"
insertAddressQuery = "INSERT INTO mysql.haskell_address (id,number,street) VALUES(?,?,?)"
selectByAddressIdQuery = "SELECT * FROM haskell_address WHERE id=(?)"
-- | MySQL CRUD
-- -------------
-- | User
-- ---------
{-| Function for select all. We select we use [queryStmt] operator followed by the statement created previously.
For the prepare statement we use the [prepareStmt] operator followed by the connection and query.
For all this operations since access to database is blocking, we use green threads by [ForkIO] -}
getAllUsers :: IO [User]
getAllUsers = do
emptyVar <- newEmptyMVar
forkIO $ do
conn <- createConnection
liftIO $ putStrLn ("Preparing connection:")
s <- prepareStmt conn selectAllQuery
(_, inputStream) <- queryStmt conn s [MySQLInt32U 18]
maybeUsers <- return (Streams.toList inputStream)
users <- liftIO $ transformMySQLValueArrayToUsers <$> maybeUsers
putMVar emptyVar users
users <- takeMVar emptyVar
return users
{-| Function for select. We select we use [query] operator followed by the connection, query and a QueryParam-}
getUserById :: Int -> IO (Either UserNotFound User)
getUserById id = let userId = id in do
emptyVar <- newEmptyMVar
forkIO $ do
conn <- createConnection
maybeMySQLValue <- executeQuery (toUserId userId) conn
putMVar emptyVar maybeMySQLValue
maybeMySQLValue <- takeMVar emptyVar
return $ transformMaybeMySQLValueToUser maybeMySQLValue
{-| Function for select. We use [query] operator followed by the connection, query and a QueryParam-}
getUserByUserName :: String -> IO (Either UserNotFound User)
getUserByUserName _name = let name = _name in do
emptyVar <- newEmptyMVar
forkIO $ do
conn <- createConnection
maybeMySQLValue <- executeQuery (toUserName name) conn
putMVar emptyVar maybeMySQLValue
maybeMySQLValue <- takeMVar emptyVar
return $ transformMaybeMySQLValueToUser maybeMySQLValue
{-|Function for insert. We use [execute] operator followed by the connection, query and an array of QueryParam-}
insertUser :: User -> IO OK
insertUser _user = let user = _user in do
emptyVar <- newEmptyMVar
forkIO $ do
conn <- createConnection
status <- executeCommand user conn
putMVar emptyVar status
status <- takeMVar emptyVar
return status
{-| Function for delete. We use [query] operator followed by the connection, query and a QueryParam-}
deleteMySQLUserById :: Int -> IO OK
deleteMySQLUserById id = let userId = id in do
emptyVar <- newEmptyMVar
forkIO $ do
conn <- createConnection
status <- executeCommand (toUserId userId) conn
putMVar emptyVar status
status <- takeMVar emptyVar
return status
{-| Function for update. we use [execute] operator followed by the connection,update query and an array of QueryParam with data to update and filter-}
updateUserById :: User -> IO OK
updateUserById _user = let user = _user in do
emptyVar <- newEmptyMVar
forkIO $ do
conn <- createConnection
status <- executeUpdateQuery user conn
putMVar emptyVar status
status <- takeMVar emptyVar
return status
-- | Address
-- ---------
insertAddress :: Address -> IO OK
insertAddress _address = let address = _address in do
emptyVar <- newEmptyMVar
forkIO $ do
conn <- createConnection
status <- executeCommand address conn
putMVar emptyVar status
status <- takeMVar emptyVar
return status
getAddressById :: Int -> IO Address
getAddressById id = let addressId = id in do
emptyVar <- newEmptyMVar
forkIO $ do
conn <- createConnection
maybeMySQLValue <- executeQuery (toAddressId addressId) conn
putMVar emptyVar maybeMySQLValue
maybeMySQLValue <- takeMVar emptyVar
return $ transformMaybeMySQLValueToAddress maybeMySQLValue
-- | Type classes
-- ----------------
-- | Commands
{-| Type class definition for commands-}
class Commands x y z where
executeCommand :: x -> y -> IO z
{-| Type class implementation to Execute the insert user query-}
instance Commands User MySQLConn OK where
executeCommand user conn = execute conn insertUserQuery [MySQLInt32 (intToInt32 $ getUserId user), MySQLText (T.pack $ getUserName user)]
{-| Type class implementation to Execute the insert Address query-}
instance Commands Address MySQLConn OK where
executeCommand address conn = execute conn insertAddressQuery [MySQLInt32 (intToInt32 $ getAddressId address),
MySQLInt32(intToInt32 $ getAddressNumber address),
MySQLText (T.pack $ getAddressStreet address)]
{-| Type class implementation to Execute the delete query-}
instance Commands UserId MySQLConn OK where
executeCommand userId conn = execute conn deleteByIdQuery [One $ MySQLInt32 (intToInt32 $ fromUserId userId)]
-- | Queries
{-| Type class definition for queries-}
class Queries x y z k where
executeQuery :: x -> y -> IO (z [k])
{-| Type class implementation to Execute the select By Id query-}
instance Queries UserId MySQLConn Maybe MySQLValue where
executeQuery userId conn = do (columnDef, inputStream) <- query conn selectByIdQuery [One $ MySQLInt32 (intToInt32 (fromUserId userId))]
maybe <- (Streams.read inputStream)
return maybe
{-| Type class implementation to Execute the select By Address query-}
instance Queries AddressId MySQLConn Maybe MySQLValue where
executeQuery addressId conn = do (columnDef, inputStream) <- query conn selectByAddressIdQuery [One $ MySQLInt32 (intToInt32 (fromAddressId addressId))]
maybe <- (Streams.read inputStream)
return maybe
{-| Type class implementation to Execute the select By name query-}
instance Queries Username MySQLConn Maybe MySQLValue where
executeQuery userName conn = do (columnDef, inputStream) <- query conn selectByNameQuery [One $ MySQLText (T.pack $ fromUserName userName)]
maybe <- (Streams.read inputStream)
return maybe
{-| Function to Execute the update query-}
executeUpdateQuery :: User -> MySQLConn -> IO OK
executeUpdateQuery user conn = execute conn updateUserQuery [MySQLInt32 (intToInt32 $ getUserId user), MySQLText (T.pack $ getUserName user),MySQLInt32 (intToInt32 $ getUserId user)]
-- | Transformation utils
-- -------------------------
{-| Function to extract the MySQLValue from Maybe and transform into User calling another function-}
transformMaybeMySQLValueToUser :: Maybe [MySQLValue] -> Either UserNotFound User
transformMaybeMySQLValueToUser maybeMySQLValue = case maybeMySQLValue of
Just mysqlValue -> Right $ transformToUser mysqlValue
Nothing -> Left $ UserNotFound "User not found"
{-| Function to extract the MySQLValue from Maybe and transform into Address calling another function-}
transformMaybeMySQLValueToAddress :: Maybe [MySQLValue] -> Address
transformMaybeMySQLValueToAddress maybeMySQLValue = case maybeMySQLValue of
Just mysqlValue -> transformToAddress mysqlValue
Nothing -> Address 0 0 "default address"
{-| Function that take an array of [[MySQLValue]] and transform every element into [User]-}
transformMySQLValueArrayToUsers :: [[MySQLValue]] -> [User]
transformMySQLValueArrayToUsers mysqlValues = map (\mysqlValue -> transformToUser mysqlValue) mysqlValues
{-| Function to receive the row [MySQLValue] and we define the fields of the row to be extracted, and after change
format of types using some utils functions we create the User instance.
In order to transform from Text to String we just need to use the operator [unpack] to extract the String -}
transformToUser :: [MySQLValue] -> User
transformToUser [MySQLInt32 row_userId, MySQLText row_userName] = User (int32ToInt row_userId) (T.unpack row_userName)
transformToAddress :: [MySQLValue] -> Address
transformToAddress [MySQLInt32 row_id, MySQLInt32 row_number, MySQLText row_street] = Address (int32ToInt row_id)(int32ToInt row_number) (T.unpack row_street)
{-| We use [connect] operator together with [defaultConnectInfo] with the info to connect to the MySQL Server-}
createConnection :: IO MySQLConn
createConnection = connect defaultConnectInfo {ciUser = "root", ciPassword = "root", ciDatabase = "mysql"}
{-| Using mysql-haskell [Streams.read] operator we able to transform the inputStream into Maybe[Type]-}
readInputStream :: InputStream a -> IO (Maybe a)
readInputStream inputStream = Streams.read inputStream