Permalink
Browse files

Switching to HasEnvironment class; adding 'Components'; improving the…

… ORM
  • Loading branch information...
alsonkemp committed Dec 26, 2008
1 parent d64e562 commit 1e33cd063a9b40de72003c465fa1363f05bc882e
View
@@ -5,6 +5,7 @@ module Config.App (
newAppEnvironment,
databaseConnection,
Connection,
+ customSetupFilters,
customPreFilters,
customPostFilters,
logLevel
@@ -34,6 +35,7 @@ databaseConnection = Just $ connectPostgreSQL "host=localhost dbname=turbinado u
----------------------------------------------------------------
-- RequestHandler Filter List additions
----------------------------------------------------------------
+customSetupFilters = []
customPreFilters = []
customPostFilters = []
View
@@ -18,24 +18,27 @@ compileArgs =
, "-odir " ++ compiledDir
, "-hidir " ++ compiledDir
, "-package HDBC"
- ] ++ (map ("-i"++) searchDirs)
+ ]
mUserPkgConf = [""]
----------------------------------------------------------------
-- Paths
----------------------------------------------------------------
+layoutDir = "App/Layouts"
+layoutStub = "Turbinado/Stubs/Layout.hs"
modelDir = "App/Models"
viewDir = "App/Views"
viewStub = "Turbinado/Stubs/View.hs"
-layoutDir = "App/Layouts"
-layoutStub = "Turbinado/Stubs/Layout.hs"
controllerDir = "App/Controllers"
controllerStub = "Turbinado/Stubs/Controller.hs"
+componentViewDir = "App/Components/Views"
+componentViewStub = "Turbinado/Stubs/ComponentView.hs"
+componentControllerDir = "App/Components/Controllers"
+componentControllerStub = "Turbinado/Stubs/ComponentController.hs"
configDir = "Config"
-searchDirs = [modelDir, viewDir, layoutDir, controllerDir, rootDir, configDir, compiledDir]
staticDirs = ["static", "tmp/cache"]
compiledDir = "tmp/compiled"
View
@@ -2,9 +2,8 @@ module Turbinado.Controller (
-- limited export from Turbinado.Controller.Monad
Controller,
runController,
- get, put,
-- * Functions
- doIO, catch,
+ liftIO, catch,
redirectTo,
-- * Database
@@ -67,15 +66,15 @@ redirectTo l = redirectResponse l
quickQuery :: String -> [HDBC.SqlValue] -> Controller [[HDBC.SqlValue]]
quickQuery s vs = do e <- get
let c = fromJust $ getDatabase e
- doIO $ HDBC.handleSqlError $ HDBC.quickQuery c s vs
+ liftIO $ HDBC.handleSqlError $ HDBC.quickQuery c s vs
quickQuery' :: String -> [HDBC.SqlValue] -> Controller [[HDBC.SqlValue]]
quickQuery' s vs = do e <- get
let c = fromJust $ getDatabase e
- doIO $ HDBC.handleSqlError $ HDBC.quickQuery' c s vs
+ liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' c s vs
run :: String -> [HDBC.SqlValue] -> Controller Integer
run s vs = do e <- get
let c = fromJust $ getDatabase e
- doIO $ HDBC.handleSqlError $ HDBC.run c s vs
+ liftIO $ HDBC.handleSqlError $ HDBC.run c s vs
@@ -7,13 +7,13 @@ module Turbinado.Controller.Monad (
get,
put,
-- * Functions
- doIO, catch
+ liftIO, catch
) where
import Control.Exception (catchDyn)
import Control.Monad.State
-import Control.Monad.Trans (MonadIO(..))
+import Control.Monad.Trans (MonadIO(..), liftIO)
import Data.Maybe
import Prelude hiding (catch)
@@ -30,6 +30,9 @@ import Turbinado.Utility.General
type Controller = StateT Environment IO
+instance HasEnvironment Controller where
+ getEnvironment = get
+ setEnvironment = put
-- | Runs a Controller computation in a particular environment. Since Controller wraps the IO monad,
-- the result of running it will be an IO computation.
@@ -39,10 +42,6 @@ runController c e = (execStateT c) e
withController :: (Environment -> Environment) -> Controller a -> Controller a
withController = withStateT
--- | Execute an IO computation within the Controller monad.
-doIO :: IO a -> Controller a
-doIO = liftIO
-
-----------------------------------------------------------------------
-- Exception handling
@@ -49,8 +49,12 @@ generateModel t typeName pk cs =
, ""
, "import App.Models.Bases.ModelBase"
, "import qualified Database.HDBC as HDBC"
+ , "import Data.Maybe"
, "import System.Time"
, ""
+ , "import Turbinado.Environment.Types"
+ , "import Turbinado.Environment.Database"
+ , ""
, "data " ++ typeName ++ " = " ++ typeName ++ " {"
] ++
[intercalate "," (map columnToFieldLabel (M.toList cs))] ++
@@ -89,26 +93,31 @@ generateModelBase = unlines $
,"import Database.HDBC"
,"import Data.Int"
,""
- ,"import Turbinado.Controller.Monad"
+ ,"import Turbinado.Environment.Types"
,""
,"-- Using phantom types here "
,"class DatabaseModel m where"
," tableName :: m -> String"
,""
,"type SelectString = String"
,"type SelectParams = [SqlValue]"
+ ,"type OrderByParams = String"
,""
,"class (DatabaseModel model) =>"
," IsModel model where"
- ," insert :: (MonadIO m, IConnection conn) => conn -> model -> m Integer"
- ," findAll :: (MonadIO m, IConnection conn) => conn -> m [model]"
- ," findAllBy :: (MonadIO m, IConnection conn) => conn -> SelectString -> SelectParams -> m [model]"
- ," findOneBy :: (MonadIO m, IConnection conn) => conn -> SelectString -> SelectParams -> m model"
+ ," insert :: (HasEnvironment m) => model -> m Integer"
+ ," findAll :: (HasEnvironment m) => m [model]"
+ ," findAllWhere :: (HasEnvironment m) => SelectString -> SelectParams -> m [model]"
+ ," findAllOrderBy :: (HasEnvironment m) => OrderByParams -> m [model]"
+ ," findAllWhereOrderBy :: (HasEnvironment m) => SelectString -> SelectParams -> OrderByParams -> m [model]"
+ ," findOneWhere :: (HasEnvironment m) => SelectString -> SelectParams -> m model"
+ ," findOneOrderBy :: (HasEnvironment m) => OrderByParams -> m model"
+ ," findOneWhereOrderBy :: (HasEnvironment m) => SelectString -> SelectParams -> OrderByParams -> m model"
,""
,"class (DatabaseModel model) =>"
," HasFindByPrimaryKey model primaryKey | model -> primaryKey where"
- ," find :: (MonadIO m, IConnection conn) => conn -> primaryKey -> m model"
- ," update :: (MonadIO m, IConnection conn) => conn -> model -> m () "
+ ," find :: (HasEnvironment m) => primaryKey -> m model"
+ ," update :: (HasEnvironment m) => model -> m () "
,""
]
@@ -119,20 +128,40 @@ generateModelBase = unlines $
generateIsModel :: TableName -> Columns -> TypeName -> [String]
generateIsModel t cs typeName =
["instance IsModel " ++ typeName ++ " where"
- ," insert conn m = do"
- ," res <- liftIO $ HDBC.run conn \" INSERT INTO " ++ t ++ " (" ++ (concat $ intersperse "," $ M.keys cs) ++") VALUES (" ++ (intercalate "," (take (M.size cs) (repeat "?"))) ++ ")\""
+ ," insert m = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.run conn \" INSERT INTO " ++ t ++ " (" ++ (concat $ intersperse "," $ M.keys cs) ++") VALUES (" ++ (intercalate "," (take (M.size cs) (repeat "?"))) ++ ")\""
," [" ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") (M.keys cs) ) ++ "]"
- ," liftIO $ HDBC.commit conn"
- ," i <- liftIO $ HDBC.catchSql (HDBC.quickQuery' conn \"SELECT lastval()\" []) (\\_ -> HDBC.commit conn >> (return $ [[HDBC.toSql (0 :: Int)]]) ) "
+ ," liftIO $ HDBC.handleSqlError $ HDBC.commit conn"
+ ," i <- liftIO $ HDBC.catchSql (HDBC.handleSqlError $ HDBC.quickQuery' conn \"SELECT lastval()\" []) (\\_ -> HDBC.commit conn >> (return $ [[HDBC.toSql (0 :: Int)]]) ) "
," return $ HDBC.fromSql $ head $ head i"
- ," findAll conn = do"
- ," res <- liftIO $ HDBC.quickQuery' conn \"SELECT " ++ cols cs ++ " FROM " ++ t ++ "\" []"
+ ," findAll = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn \"SELECT " ++ cols cs ++ " FROM " ++ t ++ "\" []"
+ ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
+ ," findAllWhere ss sp = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") \") sp"
+ ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
+ ," findAllOrderBy op = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " ORDER BY ?\") [HDBC.toSql op]"
," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
- ," findAllBy conn ss sp = do"
- ," res <- liftIO $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") \") sp"
+ ," findAllWhereOrderBy ss sp op = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") ORDER BY ? \") (sp ++ [HDBC.toSql op])"
," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
- ," findOneBy conn ss sp = do"
- ," res <- liftIO $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
+ ," findOneWhere ss sp = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
+ ," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
+ ," findOneOrderBy op = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " ORDER BY ? LIMIT 1\") [HDBC.toSql op]"
+ ," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
+ ," findOneWhereOrderBy ss sp op = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") ORDER BY ? LIMIT 1\") (sp ++ [HDBC.toSql op])"
," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
]
@@ -141,8 +170,9 @@ generateHasFindByPrimaryKey t cs typeName pk =
case (length pk) of
0 -> [""]
_ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (map (\c -> getHaskellTypeString $ colType $ (\(c',_,_) -> c') $ fromJust $ M.lookup c cs) pk)) ++ ") " ++ " where"
- ," find conn pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length pk)]) ++ ") = do"
- ," res <- liftIO $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t ++ " WHERE (" ++ (generatePrimaryKeyWhere pk) ++ ")\") [" ++ (unwords $ intersperse "," $ map (\(c,i) -> "HDBC.toSql pk" ++ (show i)) (zip pk [1..])) ++ "]"
+ ," find pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length pk)]) ++ ") = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," 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..])) ++ "]"
," case res of"
," [] -> throwDyn $ HDBC.SqlError"
," {HDBC.seState = \"\","
@@ -156,10 +186,11 @@ generateHasFindByPrimaryKey t cs typeName pk =
," HDBC.seErrorMsg = \"Too many records found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
," }"
,""
- ," update conn m = do"
- ," res <- liftIO $ HDBC.run conn \"UPDATE " ++ t ++ " SET (" ++ (unwords $ intersperse "," $ M.keys cs) ++ ") = (" ++ (intercalate "," $ (take (M.size cs) (repeat "?"))) ++ ") WHERE (" ++ (generatePrimaryKeyWhere pk) ++")\""
+ ," update m = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.run conn \"UPDATE " ++ t ++ " SET (" ++ (unwords $ intersperse "," $ M.keys cs) ++ ") = (" ++ (intercalate "," $ (take (M.size cs) (repeat "?"))) ++ ") WHERE (" ++ (generatePrimaryKeyWhere pk) ++")\""
," [" ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") (M.keys cs) ) ++ ", " ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") pk ) ++ "]"
- ," liftIO $ HDBC.commit conn"
+ ," liftIO $ HDBC.handleSqlError $ HDBC.commit conn"
," return ()"
]
@@ -215,11 +246,11 @@ getHaskellTypeString SqlUTCTimeT = "TimeDiff"
getHaskellTypeString _ = error "Don't know how to translate this SqlTypeId to a SqlValue"
-type SelectParameters = String
+--type SelectParameters = String
-class TableType a where
- find :: (IConnection conn) => conn -> Int -> a
- findBy :: (IConnection conn) => conn -> SelectParameters -> [a]
+--class TableType a where
+-- find :: (IConnection conn) => conn -> Int -> a
+-- findBy :: (IConnection conn) => conn -> SelectParameters -> [a]
--
-- Converts "column_name" to "ColumnName" (for types)
Oops, something went wrong.

0 comments on commit 1e33cd0

Please sign in to comment.