PageRenderTime 54ms CodeModel.GetById 25ms RepoModel.GetById 0ms app.codeStats 0ms

/Turbinado/Database/ORM/Adapters/Common.hs

http://github.com/alsonkemp/turbinado
Haskell | 364 lines | 321 code | 27 blank | 16 comment | 10 complexity | 6ef2c899f2f9a74d5efd94486800ea01 MD5 | raw file
Possible License(s): BSD-3-Clause
  1. module Turbinado.Database.ORM.Adapters.Common where
  2. import qualified Data.Char
  3. import Control.Monad
  4. import Data.Dynamic
  5. import qualified Data.Map as M
  6. import Data.Maybe
  7. import Data.List
  8. import Database.HDBC
  9. import System.Directory
  10. import System.FilePath
  11. import Turbinado.Database.ORM.Common
  12. import Turbinado.Database.ORM.Types
  13. ---------------------------------------------------------------------------
  14. -- File templates --
  15. ---------------------------------------------------------------------------
  16. generateType :: TableName ->
  17. TypeName ->
  18. PrimaryKey ->
  19. Tables ->
  20. Columns ->
  21. String
  22. generateType t typeName pk ts cs =
  23. unlines $
  24. ["{- DO NOT EDIT THIS FILE"
  25. ," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD"
  26. ,""
  27. ," All changes should go into the Model file (e.g. App/Models/ExampleModel.hs)"
  28. ,"-}"
  29. ,""
  30. ,"module App.Models.Bases." ++ typeName ++ "Type where"
  31. , ""
  32. , "import App.Models.Bases.Common"
  33. , "import Data.Maybe"
  34. , "import Data.Time"
  35. , "import Data.Typeable"
  36. , ""
  37. ] ++
  38. ["-- The data type for this model"] ++
  39. [ "data " ++ typeName ++ " = " ++ typeName ++ " {"
  40. ] ++
  41. [intercalate ",\n" (map columnToFieldLabel (M.toList cs))] ++
  42. [ " } deriving (Show, Typeable)"
  43. , ""
  44. , "instance DatabaseModel " ++ typeName ++ " where"
  45. , " tableName _ = \"" ++ t ++ "\""
  46. , ""
  47. ]
  48. generateFunctions :: TableName ->
  49. TypeName ->
  50. PrimaryKey ->
  51. Tables ->
  52. Columns ->
  53. String
  54. generateFunctions t typeName pk ts cs =
  55. unlines $
  56. ["{- DO NOT EDIT THIS FILE"
  57. ," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD"
  58. ,""
  59. ," All changes should go into the Model file (e.g. App/Models/ExampleModel.hs)"
  60. ,"-}"
  61. ,""
  62. ,"module App.Models.Bases." ++ typeName ++ "Functions where"
  63. , ""
  64. , "import App.Models.Bases.Common"
  65. , "import qualified Database.HDBC as HDBC"
  66. , "import Data.Maybe"
  67. , "import Data.Time"
  68. , ""
  69. , " -- My type"
  70. , "import App.Models.Bases." ++ typeName ++ "Type"
  71. , ""
  72. , "import Turbinado.Environment.Types"
  73. , "import Turbinado.Environment.Database"
  74. , ""
  75. ] ++
  76. [""] ++
  77. generateHasFindByPrimaryKey t cs typeName pk ++
  78. [""] ++
  79. generateIsModel t cs typeName
  80. ++
  81. [""
  82. ,"deleteWhere :: (HasEnvironment m) => SelectString -> SelectParams -> m Integer"
  83. ,"deleteWhere ss sp = do "
  84. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  85. ," catchDBErrors conn $ do"
  86. ," res <- liftIO $ HDBC.handleSqlError $ HDBC.run conn (\"DELETE FROM \\\"" ++ t ++ "\\\" WHERE (\" ++ ss ++ \") \") sp"
  87. ," return res"
  88. ]
  89. generateRelations :: TableName ->
  90. TypeName ->
  91. PrimaryKey ->
  92. Tables ->
  93. Columns ->
  94. String
  95. generateRelations t typeName pk ts cs =
  96. unlines $
  97. ["{- DO NOT EDIT THIS FILE"
  98. ," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD"
  99. ,""
  100. ," All changes should go into the Model file (e.g. App/Models/ExampleModel.hs)"
  101. ,"-}"
  102. ,""
  103. ,"module App.Models.Bases." ++ typeName ++ "Relations where"
  104. , ""
  105. , "import App.Models.Bases.Common"
  106. , "import qualified Database.HDBC as HDBC"
  107. , "import Data.Maybe"
  108. , "import Data.Time"
  109. , ""
  110. , " -- Model imports"
  111. , "import App.Models.Bases." ++ typeName ++ "Type"
  112. , unlines $ generateChildModelImports cs
  113. , unlines $ generateParentModelImports t ts
  114. , ""
  115. , "import Turbinado.Environment.Types"
  116. , "import Turbinado.Environment.Database"
  117. , ""
  118. ] ++
  119. [""] ++
  120. [""] ++
  121. generateHasChildren t cs typeName ++
  122. [""] ++
  123. [""] ++
  124. generateHasParents t ts
  125. generateChildModelImports cs =
  126. map (\ctn -> "import qualified App.Models.Bases." ++ toType ctn ++ "Type as " ++ toType ctn ++ "Type\nimport qualified App.Models.Bases." ++ toType ctn ++ "Functions as " ++ toType ctn ++ "Functions") $
  127. nub $
  128. map fst $ concat $
  129. map (\(_, fks, _) -> fks) $ M.elems cs
  130. generateParentModelImports t ts =
  131. map (\ptn -> "import qualified App.Models.Bases." ++ toType ptn ++ "Type as " ++ toType ptn ++ "Type\nimport qualified App.Models.Bases." ++ toType ptn ++ "Functions as " ++ toType ptn ++ "Functions") $
  132. nub $ filter (not . null) $
  133. map parentFilter $ M.assocs ts
  134. where parentFilter (ptn, (cs, _)) =
  135. case (filter (\(tn, _) -> t == tn) $ concat $ map (\(_, fks, _) -> fks) $ M.elems cs) of
  136. [] -> []
  137. _ -> ptn
  138. generateModelFile typeName =
  139. unlines $
  140. ["module App.Models." ++ typeName
  141. ," ( module App.Models." ++ typeName
  142. ," , module App.Models.Bases." ++ typeName ++ "Type"
  143. ," , module App.Models.Bases." ++ typeName ++ "Functions"
  144. ," , module App.Models.Bases." ++ typeName ++ "Relations"
  145. ," , module App.Models.Bases.Common"
  146. ," ) where"
  147. ,"import App.Models.Bases." ++ typeName ++ "Type"
  148. ,"import App.Models.Bases." ++ typeName ++ "Functions"
  149. ,"import App.Models.Bases." ++ typeName ++ "Relations"
  150. ,"import App.Models.Bases.Common"
  151. ]
  152. generateCommon:: String
  153. generateCommon = unlines $
  154. ["{- DO NOT EDIT THIS FILE"
  155. ," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD -}"
  156. ,""
  157. ,"module App.Models.Bases.Common("
  158. ," module App.Models.Bases.Common,"
  159. ," module Control.OldException,"
  160. ," module Control.Monad.Trans,"
  161. ," module Data.Int"
  162. ," ) where"
  163. ,""
  164. ,"import Control.Monad.Trans"
  165. ,"import Control.OldException"
  166. ,"import Database.HDBC"
  167. ,"import Data.Int"
  168. ,""
  169. ,"import Turbinado.Environment.Types"
  170. ,""
  171. ,"-- Using phantom types here "
  172. ,"class DatabaseModel m where"
  173. ," tableName :: m -> String"
  174. ,""
  175. ,"type SelectString = String"
  176. ,"type SelectParams = [SqlValue]"
  177. ,"type OrderByParams = String"
  178. ,""
  179. ,"-- Exception handling"
  180. ,""
  181. ,"catchDBErrors :: (HasEnvironment m) => ConnWrapper -> IO a -> m a"
  182. ,"catchDBErrors c fdb = liftIO $ catchSql fdb (\\e-> (handleSqlError $ rollback c) >>"
  183. ," (throwDyn $ e))"
  184. ,""
  185. ,"class (DatabaseModel model) =>"
  186. ," IsModel model where"
  187. ," insert :: (HasEnvironment m) => model -> Bool -> m (Maybe Integer)"
  188. ," findAll :: (HasEnvironment m) => m [model]"
  189. ," findAllWhere :: (HasEnvironment m) => SelectString -> SelectParams -> m [model]"
  190. ," findAllOrderBy :: (HasEnvironment m) => OrderByParams -> m [model]"
  191. ," findAllWhereOrderBy :: (HasEnvironment m) => SelectString -> SelectParams -> OrderByParams -> m [model]"
  192. ," findOneWhere :: (HasEnvironment m) => SelectString -> SelectParams -> m model"
  193. ," findOneOrderBy :: (HasEnvironment m) => OrderByParams -> m model"
  194. ," findOneWhereOrderBy :: (HasEnvironment m) => SelectString -> SelectParams -> OrderByParams -> m model"
  195. ,""
  196. ,"class (DatabaseModel model) =>"
  197. ," HasFindByPrimaryKey model primaryKey | model -> primaryKey where"
  198. ," find :: (HasEnvironment m) => primaryKey -> m model"
  199. ," delete :: (HasEnvironment m) => primaryKey -> m ()"
  200. ," update :: (HasEnvironment m) => model -> m ()"
  201. ,""
  202. ]
  203. ---------------------------------------------------------------------------
  204. -- Generator templates --
  205. ---------------------------------------------------------------------------
  206. generateIsModel :: TableName -> Columns -> TypeName -> [String]
  207. generateIsModel t cs typeName =
  208. ["instance IsModel " ++ typeName ++ " where"
  209. ," insert m returnId = do"
  210. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  211. ," catchDBErrors conn $ do"
  212. ," res <- HDBC.run conn (\" INSERT INTO \\\"" ++ t ++ "\\\" (" ++ (cols cs) ++") VALUES (" ++ (intercalate "," $ map generateQs (M.assocs cs) ) ++ ")\") ( " ++ (intercalate " ++ " $ filter (not . null) $ map generateArgs (M.assocs cs) ) ++ ")"
  213. ," case res of"
  214. ," 0 -> (HDBC.handleSqlError $ HDBC.rollback conn) >>"
  215. ," (throwDyn $ HDBC.SqlError"
  216. ," {HDBC.seState = \"\","
  217. ," HDBC.seNativeError = (-1),"
  218. ," HDBC.seErrorMsg = \"Rolling back. No record inserted :" ++ t ++ " : \" ++ (show m)"
  219. ," })"
  220. ," 1 -> HDBC.handleSqlError $ HDBC.commit conn >>"
  221. ," if returnId"
  222. ," then do i <- HDBC.catchSql (HDBC.handleSqlError $ HDBC.quickQuery' conn \"SELECT lastval()\" []) (\\_ -> HDBC.commit conn >> (return $ [[HDBC.toSql (0 :: Integer)]]) ) "
  223. ," return $ HDBC.fromSql $ head $ head i"
  224. ," else return Nothing"
  225. ," findAll = do"
  226. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  227. ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn \"SELECT " ++ cols cs ++ " FROM \\\"" ++ t ++ "\\\" \" []"
  228. ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
  229. ," findAllWhere ss sp = do"
  230. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  231. ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM \\\"" ++ t++ "\\\" WHERE (\" ++ ss ++ \") \") sp"
  232. ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
  233. ," findAllOrderBy op = do"
  234. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  235. ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM \\\"" ++ t++ "\\\" ORDER BY \" ++ op) []"
  236. ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
  237. ," findAllWhereOrderBy ss sp op = do"
  238. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  239. ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM \\\"" ++ t++ "\\\" WHERE (\" ++ ss ++ \") ORDER BY \" ++ op) sp"
  240. ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
  241. ," findOneWhere ss sp = do"
  242. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  243. ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM \\\"" ++ t++ "\\\" WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
  244. ," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
  245. ," findOneOrderBy op = do"
  246. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  247. ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM \\\"" ++ t++ "\\\" ORDER BY \" ++ op ++ \" LIMIT 1\") []"
  248. ," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
  249. ," findOneWhereOrderBy ss sp op = do"
  250. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  251. ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM \\\"" ++ t++ "\\\" WHERE (\" ++ ss ++ \") ORDER BY \" ++ op ++\" LIMIT 1\") sp"
  252. ," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
  253. ]
  254. where generateQs :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) -> String
  255. generateQs (c, (desc, _, False)) = if ((colNullable desc) == Just True) then ("\" ++ (case (" ++ toFunction c ++ " m) of Nothing -> \"DEFAULT\"; Just x -> \"?\") ++ \"") else "?"
  256. generateQs (c, (_, _, True)) = "\" ++ (case (" ++ toFunction c ++ " m) of Nothing -> \"DEFAULT\"; Just x -> \"?\") ++ \""
  257. generateArgs :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) -> String
  258. generateArgs (c, (desc, _, False)) = if ((colNullable desc) == Just True) then ("(case (" ++ toFunction c ++ " m) of Nothing -> []; Just x -> [HDBC.toSql x])") else ("[HDBC.toSql $ " ++ toFunction c ++ " m]")
  259. generateArgs (c, (_, _, True)) = "(case (" ++ toFunction c ++ " m) of Nothing -> []; Just x -> [HDBC.toSql x])"
  260. generateHasFindByPrimaryKey :: TableName -> Columns -> TypeName -> PrimaryKey -> [String]
  261. generateHasFindByPrimaryKey t cs typeName pk =
  262. case (length pk) of
  263. 0 -> [""]
  264. _ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (map (\c -> getHaskellTypeString $ colType $ (\(c',_,_) -> c') $ fromJust $ M.lookup c cs) pk)) ++ ") " ++ " where"
  265. ," find pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length pk)]) ++ ") = do"
  266. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  267. ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM \\\"" ++ t ++ "\\\" WHERE (" ++ (generatePrimaryKeyWhere pk) ++ ")\") [" ++ (unwords $ intersperse "," $ map (\(c,i) -> "HDBC.toSql pk" ++ (show i)) (zip pk [1..])) ++ "]"
  268. ," case res of"
  269. ," [] -> throwDyn $ HDBC.SqlError"
  270. ," {HDBC.seState = \"\","
  271. ," HDBC.seNativeError = (-1),"
  272. ," HDBC.seErrorMsg = \"No record found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
  273. ," }"
  274. ," r:[] -> return $ " ++ (generateConstructor cs typeName)
  275. ," _ -> throwDyn $ HDBC.SqlError"
  276. ," {HDBC.seState = \"\","
  277. ," HDBC.seNativeError = (-1),"
  278. ," HDBC.seErrorMsg = \"Too many records found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
  279. ," }"
  280. ,""
  281. ," delete pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length pk)]) ++ ") = do"
  282. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  283. ," catchDBErrors conn $ do"
  284. ," res <- HDBC.run conn (\"DELETE FROM \\\"" ++ t ++ "\\\" WHERE (" ++ (generatePrimaryKeyWhere pk) ++ ")\") [" ++ (unwords $ intersperse "," $ map (\(c,i) -> "HDBC.toSql pk" ++ (show i)) (zip pk [1..])) ++ "]"
  285. ," case res of"
  286. ," 0 -> (HDBC.handleSqlError $ HDBC.rollback conn) >>"
  287. ," (throwDyn $ HDBC.SqlError"
  288. ," {HDBC.seState = \"\","
  289. ," HDBC.seNativeError = (-1),"
  290. ," HDBC.seErrorMsg = \"Rolling back. No record found when deleting by Primary Key:" ++ t ++ " : \" ++ (show pk)"
  291. ," })"
  292. ," 1 -> (HDBC.handleSqlError $ HDBC.commit conn) >> return ()"
  293. ," _ -> (HDBC.handleSqlError $ HDBC.rollback conn) >>"
  294. ," (throwDyn $ HDBC.SqlError"
  295. ," {HDBC.seState = \"\","
  296. ," HDBC.seNativeError = (-1),"
  297. ," HDBC.seErrorMsg = \"Rolling back. Too many records deleted when deleting by Primary Key:" ++ t ++ " : \" ++ (show pk)"
  298. ," })"
  299. ,""
  300. ," update m = do"
  301. ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
  302. ," catchDBErrors conn $ do"
  303. ," res <- HDBC.run conn \"UPDATE \\\"" ++ t ++ "\\\" SET (" ++ (cols cs) ++ ") = (" ++ (intercalate "," $ (take (M.size cs) (repeat "?"))) ++ ") WHERE (" ++ (generatePrimaryKeyWhere pk) ++")\""
  304. ," [" ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ toFunction c ++ " m") (M.keys cs) ) ++ ", " ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ toFunction c ++ " m") pk ) ++ "]"
  305. ," HDBC.handleSqlError $ HDBC.commit conn"
  306. ," return ()"
  307. ]
  308. generateHasChildren :: TableName -> Columns -> TypeName -> [String]
  309. generateHasChildren t cs typeName = map (\(cn, cd) -> generateHasChildren_t t cn cd typeName) $ M.assocs cs
  310. generateHasChildren_t :: TableName -> ColumnName -> ColumnDesc -> TypeName -> String
  311. generateHasChildren_t t cn (_, fks, _) typeName = unlines $ map (\(fkt, fkc) -> generateHasChildren_t_k t cn fkt fkc typeName) fks
  312. generateHasChildren_t_k :: TableName -> ColumnName -> TableName -> ColumnName -> TypeName -> String
  313. generateHasChildren_t_k t cn fkt fkc typeName =
  314. unlines $
  315. ["findAllChild" ++ toType fkt ++ " :: (HasEnvironment m) => " ++ toType t ++ " -> m [" ++ toType fkt ++ "Type." ++ toType fkt ++ "]"
  316. ,"findAllChild" ++ toType fkt ++ " p = findAllWhere \"" ++ fkc ++ " = ?\" [HDBC.toSql $ " ++ toFunction cn ++ " p]"
  317. ]
  318. generateHasParents :: TableName -> Tables -> [String]
  319. generateHasParents ctn ts =
  320. map (\(tname, cname, ptname, pcname) -> generateHasParent_t tname cname ptname pcname) $
  321. nub $ concat $
  322. map parentFilter $ M.assocs ts
  323. where parentFilter (tn, (cs', _)) = filter (\(_, _, tn', _) -> ctn == tn') $ concat $ map (\(cn, (_, fks, _)) -> map (\(ptn, pcn) -> (tn, cn, ptn, pcn)) fks) $ M.assocs cs'
  324. generateHasParent_t :: TableName -> ColumnName -> TableName -> ColumnName -> String
  325. generateHasParent_t ptn pcn ctn ccn =
  326. unlines $
  327. ["parent" ++ toType ptn ++ " :: (HasEnvironment m) => " ++ toType ctn ++ " -> m " ++ toType ptn ++ "Type." ++ toType ptn
  328. ,"parent" ++ toType ptn ++ " self = findOneWhere \"" ++ pcn ++ " = ?\" [HDBC.toSql $ " ++ toFunction ccn ++ " self]"
  329. ]
  330. {-----------------------------------------------------------------------}
  331. generatePrimaryKeyWhere pk =
  332. unwords $
  333. intersperse " AND " $
  334. map (\(c,i) -> "\\\"" ++ c ++ "\\\" = ? ") (zip pk [1..])
  335. generateConstructor cs typeName =
  336. typeName ++ " " ++ (unwords $
  337. map (\i -> "(HDBC.fromSql (r !! " ++ (show i) ++ "))") [0..((M.size cs) - 1)])