Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

merging?

  • Loading branch information...
commit a450314ceda4e930165fc51fd15b58b622e37156 1 parent 8e1febf
@alsonkemp authored
Showing with 1,234 additions and 854 deletions.
  1. +1 −3 App/Controllers/Home.hs
  2. +2 −1  Config/Routes.hs
  3. +44 −10 Turbinado/Controller.hs
  4. +8 −1 Turbinado/Controller/Monad.hs
  5. +41 −33 Turbinado/Database/ORM/Generator.hs
  6. +110 −123 Turbinado/Database/ORM/Output.hs
  7. +119 −16 Turbinado/Database/ORM/PostgreSQL.hs
  8. +13 −0 Turbinado/Database/ORM/Types.hs
  9. +33 −16 Turbinado/Environment.hs
  10. +85 −111 Turbinado/Environment/CodeStore.hs
  11. +27 −0 Turbinado/Environment/Database.hs
  12. +27 −26 Turbinado/Environment/Logger.hs
  13. +10 −21 Turbinado/Environment/MimeTypes.hs
  14. +7 −125 Turbinado/Environment/Request.hs
  15. +8 −131 Turbinado/Environment/Response.hs
  16. +16 −29 Turbinado/Environment/Routes.hs
  17. +28 −35 Turbinado/Environment/Settings.hs
  18. +118 −0 Turbinado/Environment/Types.hs
  19. +30 −20 Turbinado/Environment/ViewData.hs
  20. +18 −22 Turbinado/Server.hs
  21. +25 −23 Turbinado/Server/Handlers/ErrorHandler.hs
  22. +35 −53 Turbinado/Server/Handlers/RequestHandler.hs
  23. +9 −6 Turbinado/Server/Network.hs
  24. +46 −16 Turbinado/Server/StandardResponse.hs
  25. +15 −13 Turbinado/Server/StaticContent.hs
  26. +2 −0  Turbinado/Stubs/Controller.hs
  27. +10 −10 Turbinado/View.hs
  28. +2 −1  Turbinado/View/Helpers/Misc.hs
  29. +5 −3 Turbinado/View/Monad.hs
  30. +340 −0 static/css/pressurized.css
  31. +0 −6 static/css/turbinado.css
  32. BIN  static/favicon.ico
  33. BIN  static/images/img01.jpg
  34. BIN  static/images/img02.jpg
View
4 App/Controllers/Home.hs
@@ -9,8 +9,6 @@ performance :: Controller ()
performance = return ()
hello :: Controller ()
-hello = do e <- getEnvironment
- e' <- doIO $ clearLayout e
- put e'
+hello = clearLayout
View
3  Config/Routes.hs
@@ -1,6 +1,7 @@
module Config.Routes where
-routes = [ "/:controller/:action.:format"
+routes = [ "/:controller/:action/:id"
+ , "/:controller/:action.:format"
, "/:controller/:action"
, "/:controller"
]
View
54 Turbinado/Controller.hs
@@ -1,6 +1,4 @@
module Turbinado.Controller (
- getEnvironment,
- evalController,
-- limited export from Turbinado.Controller.Monad
Controller,
runController,
@@ -8,36 +6,72 @@ module Turbinado.Controller (
-- * Functions
doIO, catch,
- module Turbinado.Environment,
+ redirectTo,
+ -- * Database
+ quickQuery,
+ quickQuery',
+ run,
+ HDBC.SqlValue(..),
+ HDBC.SqlType(..),
+
+ module Data.Maybe,
+
module Turbinado.Environment.CodeStore,
+ module Turbinado.Environment.Logger,
module Turbinado.Environment.Request,
module Turbinado.Environment.Response,
- module Turbinado.Environment.Settings
+ module Turbinado.Environment.Settings,
+ module Turbinado.Environment.Types,
+ module Turbinado.Environment.ViewData
) where
import Control.Exception (catchDyn)
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans (MonadIO(..))
+import Data.Maybe
import qualified Network.HTTP as HTTP
import Prelude hiding (catch)
+import qualified Database.HDBC as HDBC
-import Turbinado.Environment
+import Turbinado.Environment.Database
+import Turbinado.Environment.Logger
import Turbinado.Environment.Request
import Turbinado.Environment.Response
import Turbinado.Environment.Settings
+import Turbinado.Environment.Types
+import Turbinado.Environment.ViewData
import Turbinado.Controller.Monad
import Turbinado.Environment.CodeStore
import Turbinado.Utility.General
+import Turbinado.Server.StandardResponse
+-- evalController :: Controller () -> Environment -> IO Environment
+-- evalController p = runController p e
-evalController :: Controller () -> EnvironmentFilter
-evalController p e = runController p e
+--
+-- * Helper functions
+--
+redirectTo :: String -> Controller ()
+redirectTo l = redirectResponse l
--
--- * Environment functions
+-- * Database functions
--
-getEnvironment :: Controller Environment
-getEnvironment = get
+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
+
+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
+
+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
+
View
9 Turbinado/Controller/Monad.hs
@@ -2,6 +2,10 @@ module Turbinado.Controller.Monad (
-- * The 'Controller' Monad
Controller,
runController,
+ withController,
+
+ get,
+ put,
-- * Functions
doIO, catch
) where
@@ -13,7 +17,7 @@ import Control.Monad.Trans (MonadIO(..))
import Data.Maybe
import Prelude hiding (catch)
-import Turbinado.Environment
+import Turbinado.Environment.Types
import Turbinado.Controller.Exception
import Turbinado.Utility.General
@@ -32,6 +36,9 @@ type Controller = StateT Environment IO
runController :: Controller () -> Environment -> IO Environment
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
View
74 Turbinado/Database/ORM/Generator.hs
@@ -1,38 +1,46 @@
module Turbinado.Database.ORM.Generator where
-
+import Control.Monad
+import Data.List
import qualified Data.Map as M
-
-
-type ConnectionString = String
-type TableName = String
-type ColumnName = String
-type Column = (SqlColDesc, DependentKeys, Boolean) -- Boolean == isPrimaryKey
-type DependentKeys = [(TableName, ColumnName)] -- all columns which are targets of foreign keys
-
-type TableColumn = (TableName, ColumnName)
-type TableColumns = M.Map TableColumn Column
-
-generateModels :: FilePath -> IO ()
-generateModels cs fp = do conn <- openDBConnection
- ts <- Database.HDBC.getTables conn
- ds <- zip ts $ mapM (describeTable conn) ts
- let tcs = combineTablesColumns ts ds
- pks <- getPrimaryKeys conn t
- let tcs' = combinePrimaryKeys tcs pks
- fks <- getForeignKeys t
- let tcs'' = foldl
+import Data.Maybe
+import Database.HDBC
+
+import Config.Master
+import Turbinado.Database.ORM.Types
+import Turbinado.Database.ORM.Output
+import Turbinado.Database.ORM.PostgreSQL
+
+generateModels :: IO ()
+generateModels = do conn <- fromJust databaseConnection
+ ts <- getTables conn
+ -- TODO: Pull in indices
+ tcs <- foldM (buildTable conn) (M.empty) ts
+ writeModels tcs
-combineTablesColumns :: [TableName] -> [(ColumnName, SqlColDesc)] -> TableColumn
-combineTablesColumsn ts cs =
- M.fromList $ zipWith (\t (c, d) -> ((t,c), (d, [], False)) ) ts cs
-
-combinePrimaryKeys :: [(TableName, [ColumnName])] -> TableColumns -> TableColumns
-combinePrimaryKeys pks tcs =
- foldl (\tcs (t, cs) -> foldl (\c -> M.adjust (\(d,k,_) -> (d, k, True)) (t, c) ) tcs cs) tcs pks
-
-addDependentKey :: (TableColumn, TableColumn) -> TableColumns -> TableColumns
-addDependentKey (parTable, parColumn), ((depTable, depColumn)) t =
- let c@(d, k, i) = M.lookup (parTable, parColumn) t in
- M.insert (parTable, parColumn) (d, k `union` (depTable, depColumn), i)
+buildTable conn tcs t = do ds <- describeTable conn t
+ let tcs' = combineDescription t ds tcs
+ pks <- getPrimaryKeys conn t
+ let tcs'' = combinePrimaryKeys t pks tcs'
+ fks <- getForeignKeyReferences conn t
+ return $ combineForeignKeyReferences t fks tcs''
+
+combineDescription t ds tcs = M.insert t (cols, []) tcs
+ where cols = M.fromList $
+ map (\(columnName, columnDescription) -> (columnName, (columnDescription,[]))) ds
+
+combinePrimaryKeys :: TableName -> [ColumnName] -> Tables -> Tables
+combinePrimaryKeys t pks tcs = M.adjust (\(c, _) -> (c,pks)) t tcs
+
+combineForeignKeyReferences :: TableName -> [(ColumnName, TableName, ColumnName)] -> Tables -> Tables
+combineForeignKeyReferences t fks tcs =
+ M.adjust
+ (\(cs, pks) -> (foldl (worker) cs fks, pks))
+ t tcs
+ where worker cs (c, tt, tc) = M.adjust (\(cd, deps) -> (cd, [(tt, tc)] `union` deps)) c cs
+{-
+ - combineTablesColumns :: [TableName] -> [(ColumnName, SqlColDesc)] -> Tables
+ - combineTablesColumsn ts cs =
+ - M.fromList $ zipWith (\t (c, d) -> (t, (c, [])) ) ts cs
+ -}
View
233 Turbinado/Database/ORM/Output.hs
@@ -1,46 +1,74 @@
-module Database.HDBC.Generator where
+module Turbinado.Database.ORM.Output where
+
import qualified Data.Char
import Control.Monad
import Data.Dynamic
+import qualified Data.Map as M
+import Data.Maybe
import Data.List
import Database.HDBC
import System.Directory
+import System.FilePath
+
+import Turbinado.Database.ORM.Types
-type TableName = String
-type ParentName = String
type TypeName = String
-type PrimaryKeyColumnNames = [String]
-type PrimaryKeyTypeNames = [String]
-
-data TableSpec = TableSpec {
- tableName :: String,
- primaryKey :: (PrimaryKeyColumnNames, PrimaryKeyTypeNames),
- columnDescriptions :: [(String, SqlColDesc)]
- }
-
-generateModels conn parentName =
- do writeFile "Bases/ModelBase.hs" generateModelBase
- mapM (\t -> let typeName = (capitalizeName t)
+
+-- TODO: This file needs to be completely torn up and generalized.
+
+writeModels ts =
+ do writeFile "App/Models/Bases/ModelBase.hs" generateModelBase
+ mapM_ (\(t, (cs, pk)) ->
+ let typeName = (capitalizeName t)
fullName = typeName ++ "Model" in
- do desc <- describeTable conn t
- writeFile ("Bases/" ++ fullName ++ "Base.hs") (generateModel parentName typeName (TableSpec t (getPrimaryKeysFromDesc desc) desc))
- doesFileExist (fullName ++ ".hs") >>= (\e -> when (not e) (writeFile (fullName++".hs") (generateModelFile parentName typeName) ) ) )
- =<< (getTables conn)
-
-getPrimaryKeysFromDesc:: [(String, SqlColDesc)] -> (PrimaryKeyColumnNames, PrimaryKeyTypeNames)
-getPrimaryKeysFromDesc desc =
- worker ([],[]) desc
- where worker (c,t) [] = (c,t)
- worker (c,t) (d:ds) = worker (if ((colIsPrimaryKey $ snd d) == True) then (c++[fst d], t++[getHaskellTypeString $ colType $ snd d]) else (c,t)) ds
-
-generateModelFile parentName modelName =
- let fullName = (if (length parentName > 0) then parentName ++ "." else "") ++ modelName ++ "Model"
- in unlines $
- ["module " ++ fullName
- ," ( module " ++ fullName
- ," , module Bases." ++ fullName ++ "Base "
+ do e <- doesFileExist (joinPath ["App/Models", fullName ++ ".hs"])
+ when (not e) (writeFile (joinPath ["App/Models", fullName++".hs"]) (generateModelFile typeName) )
+ writeFile (joinPath ["App/Models/Bases", fullName ++ "Base.hs"]) (generateModel t typeName pk cs)
+ ) $ M.toList ts
+
+---------------------------------------------------------------------------
+-- File templates --
+---------------------------------------------------------------------------
+
+generateModel :: TableName ->
+ TypeName ->
+ PrimaryKey ->
+ Columns ->
+ String
+generateModel t typeName pk cs =
+ unlines $
+ ["{- DO NOT EDIT THIS FILE"
+ ," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD"
+ ,""
+ ," All changes should go into the Model file (e.g. ExampleModel.hs) and"
+ ," not into the base file (e.g. ExampleModelBase.hs) -}"
+ ,""
+ ,"module Models.Bases." ++ typeName ++ "ModelBase ( "
+ ," module Models.Bases." ++ typeName ++ "ModelBase, "
+ ," module Models.Bases.ModelBase) where"
+ , ""
+ , "import Models.Bases.ModelBase"
+ , "import System.Time"
+ , ""
+ , "data " ++ typeName ++ " = " ++ typeName ++ " {"
+ ] ++
+ [intercalate "," (map columnToFieldLabel (M.toList cs))] ++
+ [ " } deriving (Eq, Show)"
+ , ""
+ , "instance DatabaseModel " ++ typeName ++ " where"
+ , " tableName _ = \"" ++ t ++ "\""
+ , ""
+ ] ++
+ generateFindByPrimaryKey t cs typeName pk ++
+ generateFinders t cs typeName
+
+generateModelFile typeName =
+ unlines $
+ ["module Models." ++ typeName ++ "Model"
+ ," ( module Models." ++ typeName ++ "Model"
+ ," , module Models.Bases." ++ typeName ++ "ModelBase"
," ) where"
- ,"import Bases." ++ fullName ++ "Base"
+ ,"import Models.Bases." ++ typeName ++ "ModelBase"
]
generateModelBase :: String
@@ -48,8 +76,8 @@ generateModelBase = unlines $
["{- DO NOT EDIT THIS FILE"
," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD -}"
,""
- ,"module ModelBase ("
- ," module ModelBase,"
+ ,"module Models.Bases.ModelBase ("
+ ," module Models.Bases.ModelBase,"
," module Control.Exception,"
," module Database.HDBC,"
," module Data.Int"
@@ -77,97 +105,69 @@ generateModelBase = unlines $
," findOneBy :: IConnection conn => conn -> SelectString -> SelectParams -> IO model"
,""
]
-{-------------------------------------------------------------------------}
-generateModel :: ParentName ->
- TypeName ->
- TableSpec ->
- String
-generateModel parentName typeName tspec =
- let cleanParentName = if (length parentName > 0) then parentName ++ "." else ""
- in unlines $
- ["{- DO NOT EDIT THIS FILE"
- ," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD"
- ,""
- ," All changes should go into the Model file (e.g. ExampleModel.hs) and"
- ," not into the base file (e.g. ExampleModelBase.hs) -}"
- ,""
- ,"module " ++ cleanParentName ++ typeName ++ "ModelBase ( "
- ," module Bases." ++ cleanParentName ++ typeName ++ "ModelBase, "
- ," module " ++ cleanParentName ++ "ModelBase) where"
- , ""
- , "import Bases." ++ cleanParentName ++ "ModelBase"
- , ""
- , "data " ++ typeName ++ " = " ++ typeName ++ " {"
- ] ++
- addCommas (map columnToFieldLabel (columnDescriptions tspec)) ++
- [ " } deriving (Eq, Show)"
- , ""
- , "instance DatabaseModel " ++ typeName ++ " where"
- , " tableName _ = \"" ++ tableName tspec ++ "\""
- , ""
- ] ++
- generateFindByPrimaryKey typeName tspec ++
- generateFinders typeName tspec
-{-------------------------------------------------------------------------}
-columnToFieldLabel :: (String, SqlColDesc) -> String
-columnToFieldLabel (name, desc) =
- " " ++ partiallyCapitalizeName name ++ " :: " ++
- (if ((colNullable desc) == Just True) then "Maybe " else "") ++
- getHaskellTypeString (colType desc)
+---------------------------------------------------------------------------
+-- Generator templates --
+---------------------------------------------------------------------------
-{-------------------------------------------------------------------------}
-generateFindByPrimaryKey :: TypeName -> TableSpec -> [String]
-generateFindByPrimaryKey typeName tspec =
- case (length $ fst $ primaryKey tspec) of
+generateFindByPrimaryKey :: TableName -> Columns -> TypeName -> PrimaryKey -> [String]
+generateFindByPrimaryKey t cs typeName pk =
+ case (length pk) of
0 -> [""]
- _ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (snd $ primaryKey tspec)) ++ ") " ++ " where"
- ," find conn pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length $ fst $ primaryKey tspec)]) ++ ") = do"
- ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (" ++ generatePrimaryKeyWhere (fst $ primaryKey tspec) ++ "++ \")\") []"
+ _ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (map (\c -> getHaskellTypeString $ colType $ fst $ fromJust $ M.lookup c cs) pk)) ++ ") " ++ " where"
+ ," find conn pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length pk)]) ++ ") = do"
+ ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t ++ " WHERE (" ++ (generatePrimaryKeyWhere pk) ++ ")\") [" ++ (unwords $ intersperse "," $ map (\(c,i) -> "toSql pk" ++ (show i)) (zip pk [1..])) ++ "]"
," case res of"
," [] -> throwDyn $ SqlError"
," {seState = \"\","
," seNativeError = (-1),"
- ," seErrorMsg = \"No record found when finding by Primary Key:" ++ (tableName tspec) ++ " : \" ++ (show pk)"
+ ," seErrorMsg = \"No record found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
," }"
- ," r:[] -> return $ " ++ (generateConstructor typeName tspec)
+ ," r:[] -> return $ " ++ (generateConstructor cs typeName)
," _ -> throwDyn $ SqlError"
," {seState = \"\","
," seNativeError = (-1),"
- ," seErrorMsg = \"Too many records found when finding by Primary Key:" ++ (tableName tspec) ++ " : \" ++ (show pk)"
+ ," seErrorMsg = \"Too many records found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
," }"
]
-generateFinders :: TypeName -> TableSpec -> [String]
-generateFinders typeName tspec =
+generateFinders :: TableName -> Columns -> TypeName -> [String]
+generateFinders t cs typeName =
["instance HasFinders " ++ typeName ++ " where"
," findAll conn = do"
- ," res <- quickQuery' conn \"SELECT * FROM " ++ tableName tspec ++ "\" []"
- ," return $ map (\\r -> " ++ generateConstructor typeName tspec ++ ") res"
+ ," res <- quickQuery' conn \"SELECT " ++ cols cs ++ " FROM " ++ t ++ "\" []"
+ ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
," findAllBy conn ss sp = do"
- ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (\" ++ ss ++ \") \") sp"
- ," return $ map (\\r -> " ++ generateConstructor typeName tspec ++ ") res"
+ ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") \") sp"
+ ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
," findOneBy conn ss sp = do"
- ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
- ," return $ (\\r -> " ++ generateConstructor typeName tspec ++ ") (head res)"
+ ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
+ ," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
]
{-----------------------------------------------------------------------}
-generatePrimaryKeyWhere cnames =
+generatePrimaryKeyWhere pk =
unwords $
intersperse "++ \" AND \" ++ \"" $
- map (\(c,i) -> c ++ " = \" ++ (show pk" ++ (show i) ++ ")") (zip cnames [1..])
+ map (\(c,i) -> c ++ " = ? ") (zip pk [1..])
-generateConstructor typeName tspec =
+generateConstructor cs typeName =
typeName ++ " " ++ (unwords $
- map (\i -> "(fromSql (r !! " ++ (show i) ++ "))") [0..((length $ columnDescriptions tspec)-1)])
+ map (\i -> "(fromSql (r !! " ++ (show i) ++ "))") [0..((M.size cs) - 1)])
+
+---------------------------------------------------------------------------
+-- Utility functions --
+---------------------------------------------------------------------------
+cols :: Columns -> String
+cols cs = unwords $ intersperse "," $ M.keys cs
+
+columnToFieldLabel :: (String, (SqlColDesc, ForeignKeyReferences)) -> String
+columnToFieldLabel (name, (desc, _)) =
+ " " ++ partiallyCapitalizeName name ++ " :: " ++
+ (if ((colNullable desc) == Just True) then "Maybe " else "") ++
+ getHaskellTypeString (colType desc)
-{-------------------------------------------------------------------------
- - Utility functions -
- -------------------------------------------------------------------------}
-addCommas (s:[]) = [s]
-addCommas (s:ss) = (s ++ ",") : (addCommas ss)
getHaskellTypeString :: SqlTypeId -> String
getHaskellTypeString SqlCharT = "String"
@@ -185,11 +185,11 @@ getHaskellTypeString SqlFloatT = "Float"
getHaskellTypeString SqlDoubleT = "Double"
getHaskellTypeString SqlTinyIntT = "Int32"
getHaskellTypeString SqlBigIntT = "Int64"
-getHaskellTypeString SqlDateT = "UTCTime"
-getHaskellTypeString SqlTimeT = "UTCTime"
-getHaskellTypeString SqlTimestampT = "UTCTime"
-getHaskellTypeString SqlUTCDateTimeT = "UTCTime"
-getHaskellTypeString SqlUTCTimeT = "UTCTime"
+getHaskellTypeString SqlDateT = "ClockTime"
+getHaskellTypeString SqlTimeT = "ClockTime"
+getHaskellTypeString SqlTimestampT = "ClockTime"
+getHaskellTypeString SqlUTCDateTimeT = "ClockTime"
+getHaskellTypeString SqlUTCTimeT = "TimeDiff"
getHaskellTypeString _ = error "Don't know how to translate this SqlTypeId to a SqlValue"
@@ -199,8 +199,9 @@ class TableType a where
find :: (IConnection conn) => conn -> Int -> a
findBy :: (IConnection conn) => conn -> SelectParameters -> [a]
-{- Converts "column_name" to "ColumnName"
- -}
+--
+-- Converts "column_name" to "ColumnName" (for types)
+--
capitalizeName colname =
concat $
map (\(s:ss) -> (Data.Char.toUpper s) : ss) $
@@ -208,23 +209,9 @@ capitalizeName colname =
map (\c -> if (c=='_') then ' ' else c) colname
+--
+-- Converts "column_name" to "columnName" (for functions)
+--
partiallyCapitalizeName colname =
(\(s:ss) -> (Data.Char.toLower s) : ss) $
capitalizeName colname
-
-{- If a column ends with "_id" then it's a foreign key
- -}
-isForeignKey colname =
- drop (length colname - 3) colname == "_id"
-
-
-{-
-PostgreSQL query to get Primary Keys:
-SELECT pg_attribute.attname
- FROM pg_class
- JOIN pg_namespace ON pg_namespace.oid=pg_class.relnamespace AND pg_namespace.nspname NOT LIKE 'pg_%' AND pg_class.relname like 'abba%'
- JOIN pg_attribute ON pg_attribute.attrelid=pg_class.oid AND pg_attribute.attisdropped='f'
- JOIN pg_index ON pg_index.indrelid=pg_class.oid AND pg_index.indisprimary='t' AND ( pg_index.indkey[0]=pg_attribute.attnum OR pg_inde
-x.indkey[1]=pg_attribute.attnum OR pg_index.indkey[2]=pg_attribute.attnum OR pg_index.indkey[3]=pg_attribute.attnum OR pg_index.indkey[4]=pg_attribute.attnum OR pg_index.indkey[5]=pg_attribute.attnum OR pg_index.indkey[6]=pg_attribute.attnum OR pg_index.indkey[7]=pg_attribute.attnum OR pg_index.indkey[8]=pg_attribute.attnum OR pg_index.indkey[9]=pg_attribute.attnum )
- ORDER BY pg_namespace.nspname, pg_class.relname,pg_attribute.attname;
--}
View
135 Turbinado/Database/ORM/PostgreSQL.hs
@@ -1,21 +1,124 @@
module Turbinado.Database.ORM.PostgreSQL where
+import Data.List
import Database.HDBC
-getPrimaryKeys :: IConnection conn => conn -> String -> [String]
-getPrimaryKeys conn t = quickQuery conn (concatenate [
- " SELECT ins.tablename, ins.indexname, i.indkey, a.*"
- ," FROM pg_indexes ins "
- ," INNER JOIN pg_class c ON ins.indexname = c.relname "
- ," INNER JOIN pg_index i ON c.oid = i.indexrelid "
- ," INNER JOIN pg_attribute a ON c.oid = a.attrelid "
- ," WHERE ins.tablename = '" ++ t ++ "' AND contype = 'f';"]) []
+import Turbinado.Database.ORM.Types
+
+getPrimaryKeys :: IConnection conn => conn -> String -> IO [String]
+getPrimaryKeys conn t =
+ do rs <- quickQuery conn (concat
+ [ "select a.attname as column_name"
+ , " from pg_constraint con"
+ , " join pg_namespace n on (n.oid = con.connamespace)"
+ , " join pg_class c on (c.oid = con.conrelid)"
+ , " join (select g.s"
+ , " from generate_series(1,current_setting('max_index_keys')::int,1) as g(s)"
+ , " ) s(i) on (s.i <= array_upper(con.conkey,1))"
+ , " join pg_attribute a on (a.attrelid = c.oid"
+ , " and a.attnum = con.conkey[i])"
+ , " where con.conrelid != 0"
+ , " and con.contype in ('p','u')"
+ , " and c.relname = ?;"]) [toSql t]
+ return $ map (\r -> fromSql $ r !! 0) rs
+
+getForeignKeyReferences :: IConnection conn => conn -> String -> IO [(String, String, String)]
+getForeignKeyReferences conn t =
+ do rs <- quickQuery conn (concat
+ [ "select a2.attname as key_column,"
+ , " c1.relname as foreign_key_table_name,"
+ , " a1.attname as foreign_key_column"
+ , " from pg_constraint k1"
+ , " join pg_namespace n1 on (n1.oid = k1.connamespace)"
+ , " join pg_class c1 on (c1.oid = k1.conrelid)"
+ , " join pg_class c2 on (c2.oid = k1.confrelid)"
+ , " join pg_namespace n2 on (n2.oid = c2.relnamespace)"
+ , " join (select g.s"
+ , " from generate_series(1,current_setting('max_index_keys')::int,1) as g(s)"
+ , " )s(i) on (s.i <= array_upper(k1.conkey,1))"
+ , " join pg_attribute a1"
+ , " on (a1.attrelid = c1.oid and a1.attnum = k1.conkey[s.i])"
+ , " join pg_attribute a2"
+ , " on (a2.attrelid = c2.oid and a2.attnum = k1.confkey[s.i])"
+ , " where k1.conrelid != 0"
+ , " and k1.confrelid != 0"
+ , " and k1.contype = 'f'"
+ , " and c2.relname = ?;"
+ ]) [toSql t]
+ return $ map (\r -> (fromSql $ r !! 0, fromSql $ r !! 1, fromSql $ r !! 2)) rs
-getForeignKeys :: IConnection conn => conn -> String -> [String]
-getForeignKeys conn t = quickQuery conn (concatenate [
- " SELECT ins.tablename, ins.indexname, i.indkey, a.*"
- ," FROM pg_indexes ins "
- ," INNER JOIN pg_class c ON ins.indexname = c.relname "
- ," INNER JOIN pg_index i ON c.oid = i.indexrelid "
- ," INNER JOIN pg_attribute a ON c.oid = a.attrelid "
- ," WHERE ins.tablename = '" ++ t ++ "';"]) []
+{-
+
+INDEX COLUMNS
+
+ select n.nspname as schema_name,
+ ct.relname as table_name,
+ ci.relname as index_name,
+ a.attname as column_name,
+ s.i as column_position,
+ n2.nspname as opclass_schema,
+ o.opcname as opclass_name,
+ pg_get_indexdef(ci.oid,s.i,true) as definition
+ from pg_index x
+ join pg_class ct on (ct.oid = x.indrelid)
+ join pg_class ci on (ci.oid = x.indexrelid)
+ join pg_namespace n on (n.oid = ct.relnamespace)
+ join _pg_sv_keypositions() s(i) on (s.i <= x.indnatts)
+ join pg_opclass o on (o.oid = x.indclass[i-1])
+ r
+ join pg_namespace n2 on (n2.oid = o.opcnamespace)
+ left join pg_attribute a on (a.attrelid = ct.oid
+ and a.attnum = x.indkey[i-1])
+ where _pg_sv_table_accessible(n.oid,ct.oid)
+ and ct.relkind = 'r' and ci.relkind = 'i';
+
+PRIMARY KEY
+
+ select n.nspname as schema_name,
+ c.relname as table_name,
+ con.conname as constraint_name,
+ con.contype = 'p' as is_primary_key,
+ a.attname as column_name,
+ s.i as column_position,
+ c.oid as table_oid
+ from pg_constraint con
+ join pg_namespace n on (n.oid = con.connamespace)
+ join pg_class c on (c.oid = con.conrelid)
+ join _pg_sv_keypositions() s(i)
+ on (s.i <= array_upper(con.conkey,1))
+ join pg_attribute a on (a.attrelid = c.oid
+ and a.attnum = con.conkey[i])
+ where con.conrelid != 0
+ and con.contype in ('p','u')
+ and _pg_sv_table_accessible(n.oid,c.oid);
+
+
+FOREIGN KEYS
+
+ select n1.nspname as foreign_key_schema_name,
+ c1.relname as foreign_key_table_name,
+ k1.conname as foreign_key_constraint_name,
+ c1.oid as foreign_key_table_oid,
+ a1.attname as foreign_key_column,
+ s.i as column_position,
+ n2.nspname as key_schema_name,
+ c2.relname as key_table_name,
+ c2.oid as key_table_oid,
+ a2.attname as key_column
+ from pg_constraint k1
+ join pg_namespace n1 on (n1.oid = k1.connamespace)
+ join pg_class c1 on (c1.oid = k1.conrelid)
+ join pg_class c2 on (c2.oid = k1.confrelid)
+ join pg_namespace n2 on (n2.oid = c2.relnamespace)
+ join _pg_sv_keypositions() s(i)
+ on (s.i <= array_upper(k1.conkey,1))
+ join pg_attribute a1
+ on (a1.attrelid = c1.oid and a1.attnum = k1.conkey[s.i])
+ join pg_attribute a2
+ on (a2.attrelid = c2.oid and a2.attnum = k1.confkey[s.i])
+ where k1.conrelid != 0
+ and k1.confrelid != 0
+ and k1.contype = 'f'
+ and _pg_sv_table_accessible(n1.oid,c1.oid);
+
+-}
View
13 Turbinado/Database/ORM/Types.hs
@@ -0,0 +1,13 @@
+module Turbinado.Database.ORM.Types where
+
+import qualified Data.Map as M
+import Database.HDBC
+
+type Tables = M.Map TableName (Columns, PrimaryKey)
+type TableName = String
+type Columns = M.Map ColumnName ColumnDesc
+type ColumnName = String
+type PrimaryKey = [ColumnName]
+type ColumnDesc = (SqlColDesc, ForeignKeyReferences)
+type ForeignKeyReferences = [(TableName, ColumnName)] -- all columns which are targets of foreign keys
+
View
49 Turbinado/Environment.hs
@@ -1,30 +1,47 @@
module Turbinado.Environment (
Environment,
- EnvironmentFilter,
newEnvironment,
- getKey,
- setKey
+ EnvironmentFilter
) where
-import Data.Dynamic
import Data.Map
import Data.Maybe
import System.IO
-import System.IO.Unsafe
-import System.Log.Logger
+import Config.Master
--- Using Dynamic for two reasons:
--- 1) Break module cycles (Environment doesn't import the various Request, Response, etc bits
--- 2) Extensibility - easy for plugins to add data to the Environment
-type Environment = Map String Dynamic
+import Turbinado.Environment.CodeStore
+import Turbinado.Environment.Logger
+import Turbinado.Environment.MimeTypes
+import Turbinado.Environment.Request
+import Turbinado.Environment.Response
+import Turbinado.Environment.Routes
+import Turbinado.Environment.Settings
+import Turbinado.Environment.ViewData
+data Environment = Environment { getCodeStore :: Maybe CodeStore
+ , getLogger :: Maybe Logger
+ , getMimeTypes :: Maybe MimeTypes
+ , request :: Maybe Request
+ , getResponse :: Maybe Response
+ , getRoutes :: Maybe Routes
+ , getSettings :: Maybe Settings
+ , getViewData :: Maybe ViewData
+ , getAppEnvironment :: Maybe AppEnvironment
+ }
+
type EnvironmentFilter = Environment -> IO Environment
newEnvironment :: IO Environment
-newEnvironment = return (empty :: Environment)
+newEnvironment = return $ Environment {
+ getCodeStore = Nothing
+ , getLogger = Nothing
+ , getMimeTypes = Nothing
+ , getRequest = Nothing
+ , getResponse = Nothing
+ , getRoutes = Nothing
+ , getSettings = Nothing
+ , getViewData = Nothing
+ , getAppEnvironment = Nothing
+ }
+
-getKey :: (Typeable a) => String -> Environment -> a
-getKey k e = fromJust $ fromDynamic $ e ! k
-
-setKey :: (Typeable a) => String -> a -> EnvironmentFilter
-setKey k v = \e -> return $ insert k (toDyn v) e
View
196 Turbinado/Environment/CodeStore.hs
@@ -1,16 +1,10 @@
module Turbinado.Environment.CodeStore (
addCodeStoreToEnvironment,
- getCodeStore,
- setCodeStore,
- CodeType (..),
retrieveCode,
- CodeStore (..),
- CodeMap,
- CodeStatus (..)
) where
import Control.Concurrent.MVar
-import Control.Exception ( catch, throwIO )
+import Control.Exception ( catch, throwIO)
import Control.Monad ( when, foldM)
import Data.Map hiding (map)
import Data.List (isPrefixOf, intersperse)
@@ -20,7 +14,7 @@ import qualified Network.HTTP as HTTP
import Prelude hiding (lookup,catch)
import System.Directory
import System.FilePath
-import System.IO
+import System.IO
import System.Plugins
import System.Plugins.Utils
import System.Time
@@ -29,140 +23,120 @@ import Config.Master
import qualified Turbinado.Server.Exception as Ex
import Turbinado.Environment.Logger
-import Turbinado.Environment
+import Turbinado.Environment.Types
import Turbinado.Environment.Request
import Turbinado.Environment.Response
-import Turbinado.View.Monad
+import Turbinado.View.Monad hiding (doIO)
import Turbinado.View.XML
import Turbinado.Controller.Monad
-type CodeDate = ClockTime
-type Function = String
-type CodeLocation = (FilePath, Function)
-
-data CodeStore = CodeStore (MVar CodeMap)
- deriving Typeable
-type CodeMap = Map CodeLocation CodeStatus
-data CodeStatus = CodeLoadFailure |
- CodeLoadController (Controller ()) Module CodeDate |
- CodeLoadView (View XML ) Module CodeDate
-
-- | Create a new store for Code data
-addCodeStoreToEnvironment :: EnvironmentFilter
-addCodeStoreToEnvironment e = do mv <- newMVar $ empty
- setCodeStore (CodeStore mv) e
-
-codeStoreKey = "codestore"
-
-getCodeStore :: Environment -> CodeStore
-getCodeStore = getKey codeStoreKey
-
-setCodeStore :: CodeStore -> EnvironmentFilter
-setCodeStore req = setKey codeStoreKey req
-
-
-data CodeType = CTView | CTController | CTLayout
-
-retrieveCode :: Environment -> CodeType -> CodeLocation -> IO CodeStatus
-retrieveCode e ct cl' = do
- let (CodeStore mv) = getCodeStore e
+addCodeStoreToEnvironment :: Controller ()
+addCodeStoreToEnvironment = do e <- get
+ mv <- doIO $ newMVar $ empty
+ put $ e {getCodeStore = Just $ CodeStore mv}
+
+retrieveCode :: CodeType -> CodeLocation -> Controller CodeStatus
+retrieveCode ct cl' = do
+ e <- get
+ let (CodeStore mv) = fromJust $ getCodeStore e
path = getDir ct
cl <- do -- d <- getCurrentDirectory
return (addExtension (joinPath $ map normalise [{- d, -} path, dropExtension $ fst cl']) "hs", snd cl')
- debugM e $ " CodeStore : retrieveCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
- cmap <- takeMVar mv
+ debugM $ " CodeStore : retrieveCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
+ cmap <- doIO $ takeMVar mv
let c= lookup cl cmap
cmap' <- case c of
- Nothing -> do debugM e ((fst cl) ++ " : " ++ (snd cl) ++ " : fresh load")
- loadCode e ct cmap cl
- Just CodeLoadFailure -> do debugM e ((fst cl) ++ " : " ++ (snd cl) ++ " : previous failure; try load")
- loadCode e ct cmap cl
- _ -> do debugM e ((fst cl) ++ " : " ++ (snd cl) ++ " : checking reload")
- checkReloadCode e ct cmap (fromJust c) cl
- putMVar mv cmap'
+ Nothing -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : fresh load")
+ loadCode ct cmap cl
+ Just CodeLoadFailure -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : previous failure; try load")
+ loadCode ct cmap cl
+ _ -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : checking reload")
+ checkReloadCode ct cmap (fromJust c) cl
+ doIO $ putMVar mv cmap'
-- We _definitely_ have a code entry now, though it may have a MakeFailure
let c' = lookup cl cmap'
case c' of
- Nothing -> do debugM e (fst cl ++ " : Not found in CodeStore")
+ Nothing -> do debugM (fst cl ++ " : Not found in CodeStore")
return CodeLoadFailure
- Just CodeLoadFailure -> do debugM e (fst cl ++ " : CodeLoadFailure " )
+ Just CodeLoadFailure -> do debugM (fst cl ++ " : CodeLoadFailure " )
return CodeLoadFailure
- Just clc@(CodeLoadController _ _ _) -> do debugM e (fst cl ++ " : CodeLoadController " )
+ Just clc@(CodeLoadController _ _ _) -> do debugM (fst cl ++ " : CodeLoadController " )
return clc
- Just clv@(CodeLoadView _ _ _) -> do debugM e (fst cl ++ " : CodeLoadView" )
+ Just clv@(CodeLoadView _ _ _) -> do debugM (fst cl ++ " : CodeLoadView" )
return clv
-checkReloadCode :: Environment -> CodeType -> CodeMap -> CodeStatus -> CodeLocation -> IO CodeMap
-checkReloadCode e ct cmap CodeLoadFailure cl = error "ERROR: checkReloadCode was called with a CodeLoadFailure"
-checkReloadCode e ct cmap cstat cl = do
- debugM e $ " CodeStore : checkReloadCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
- r <- needReloadCode e (fst cl) (getDate cstat)
+checkReloadCode :: CodeType -> CodeMap -> CodeStatus -> CodeLocation -> Controller CodeMap
+checkReloadCode ct cmap CodeLoadFailure cl = error "ERROR: checkReloadCode was called with a CodeLoadFailure"
+checkReloadCode ct cmap cstat cl = do
+ debugM $ " CodeStore : checkReloadCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
+ r <- needReloadCode (fst cl) (getDate cstat)
case r of
- False -> do debugM e $ " CodeStore : checkReloadCode : No reload neeeded"
+ False -> do debugM $ " CodeStore : checkReloadCode : No reload neeeded"
return cmap
- True -> do debugM e $ " CodeStore : checkReloadCode : Need reload"
- loadCode e ct cmap cl
+ True -> do debugM $ " CodeStore : checkReloadCode : Need reload"
+ loadCode ct cmap cl
-- The beast
-- In cases of Merge, Make or Load failures leave the original files in place and log the error
-loadCode :: Environment -> CodeType -> CodeMap -> CodeLocation -> IO CodeMap
-loadCode e ct cmap cl = do
- debugM e $ "\tCodeStore : loadCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
- fe <- doesFileExist $ fst cl
+loadCode :: CodeType -> CodeMap -> CodeLocation -> Controller CodeMap
+loadCode ct cmap cl = do
+ debugM $ "\tCodeStore : loadCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
+ fe <- doIO $ doesFileExist $ fst cl
case fe of
- False -> debugM e ("\tFile not found: " ++ fst cl) >> return cmap
- True -> mergeCode e ct cmap cl
+ False -> debugM ("\tFile not found: " ++ fst cl) >> return cmap
+ True -> mergeCode ct cmap cl
-mergeCode :: Environment -> CodeType -> CodeMap -> CodeLocation -> IO CodeMap
-mergeCode e ct cmap cl = do
- debugM e $ "\tMerging " ++ (fst cl)
+mergeCode :: CodeType -> CodeMap -> CodeLocation -> Controller CodeMap
+mergeCode ct cmap cl = do
+ debugM $ "\tMerging " ++ (fst cl)
-- d <- getCurrentDirectory
- --debugM e $ " stub " ++ joinPath [normalise d, normalise $ getStub ct]
+ --debugM $ " stub " ++ joinPath [normalise d, normalise $ getStub ct]
ms <- customMergeToDir (joinPath [{-normalise d,-} normalise $ getStub ct]) (fst cl) compiledDir
case ms of
- MergeFailure err -> do debugM e ("\tMerge error : " ++ (show err))
+ MergeFailure err -> do debugM ("\tMerge error : " ++ (show err))
return $ insert cl CodeLoadFailure cmap
- MergeSuccess NotReq _ _ -> do debugM e ("\tMerge success (No recompilation required) : " ++ (fst cl))
+ MergeSuccess NotReq _ _ -> do debugM ("\tMerge success (No recompilation required) : " ++ (fst cl))
return cmap
- MergeSuccess _ args fp -> do debugM e ("\tMerge success : " ++ (fst cl))
- makeCode e ct cmap cl args fp
+ MergeSuccess _ args fp -> do debugM ("\tMerge success : " ++ (fst cl))
+ makeCode ct cmap cl args fp
-makeCode :: Environment -> CodeType -> CodeMap -> CodeLocation -> [Arg] -> FilePath -> IO CodeMap
-makeCode e ct cmap cl args fp = do
- ms <- makeAll fp (compileArgs++args)
+makeCode :: CodeType -> CodeMap -> CodeLocation -> [Arg] -> FilePath -> Controller CodeMap
+makeCode ct cmap cl args fp = do
+ ms <- doIO $ makeAll fp (compileArgs++args)
case ms of
- MakeFailure err -> do debugM e ("\tMake error : " ++ (show err))
+ MakeFailure err -> do debugM ("\tMake error : " ++ (show err))
return (insert cl CodeLoadFailure cmap)
- MakeSuccess NotReq _ -> do debugM e ("\tMake success : No recomp required")
+ MakeSuccess NotReq _ -> do debugM ("\tMake success : No recomp required")
return (insert cl CodeLoadFailure cmap)
- MakeSuccess _ fp -> do debugM e ("\tMake success : " ++ fp)
+ MakeSuccess _ fp -> do debugM ("\tMake success : " ++ fp)
case ct of
- CTController -> _loadController e ct cmap cl fp
- _ -> _loadView e ct cmap cl fp
+ CTController -> _loadController ct cmap cl fp
+ _ -> _loadView ct cmap cl fp
-_loadController :: Environment -> CodeType -> CodeMap -> CodeLocation -> FilePath -> IO CodeMap
-_loadController e ct cmap cl fp = do
- debugM e ("loadController : " ++ (fst cl) ++ " : " ++ (snd cl))
- ls <- load_ fp [compiledDir] (snd cl)
+_loadController :: CodeType -> CodeMap -> CodeLocation -> FilePath -> Controller CodeMap
+_loadController ct cmap cl fp = do
+ debugM ("loadController : " ++ (fst cl) ++ " : " ++ (snd cl))
+ ls <- doIO $ load_ fp [compiledDir] (snd cl)
case ls of
- LoadFailure err -> do debugM e ("LoadFailure : " ++ (show err))
+ LoadFailure err -> do debugM ("LoadFailure : " ++ (show err))
return (insert cl CodeLoadFailure cmap)
- LoadSuccess m f -> do debugM e ("LoadSuccess : " ++ fst cl )
- unload m
- t <- getClockTime
+ LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
+ doIO $ unload m
+ t <- doIO $ getClockTime
return (insert cl (CodeLoadController f m t) cmap)
-_loadView :: Environment -> CodeType -> CodeMap -> CodeLocation -> FilePath -> IO CodeMap
-_loadView e ct cmap cl fp = do
- debugM e ("loadView : " ++ (fst cl) ++ " : " ++ (snd cl))
- ls <- load_ fp (compiledDir:searchDirs) (snd cl)
+_loadView :: CodeType -> CodeMap -> CodeLocation -> FilePath -> Controller CodeMap
+_loadView ct cmap cl fp = do
+ debugM ("loadView : " ++ (fst cl) ++ " : " ++ (snd cl))
+ ls <- doIO $ load_ fp (compiledDir:searchDirs) (snd cl)
case ls of
- LoadFailure err -> do debugM e ("\tLoadFailure : " ++ (show err))
+ LoadFailure err -> do debugM ("\tLoadFailure : " ++ (show err))
return (insert cl CodeLoadFailure cmap)
- LoadSuccess m f -> do debugM e ("\tLoadSuccess : " ++ fst cl )
- unload m
- t <- getClockTime
+ LoadSuccess m f -> do debugM ("\tLoadSuccess : " ++ fst cl )
+ doIO $ unload m
+ t <- doIO $ getClockTime
return (insert cl (CodeLoadView f m t) cmap)
@@ -172,10 +146,10 @@ _loadView e ct cmap cl fp = do
-- Custom merge function because I don't want to have to use a custom
-- version of Plugins (with HSX enabled)
-customMergeToDir :: FilePath -> FilePath -> FilePath -> IO MergeStatus
+customMergeToDir :: FilePath -> FilePath -> FilePath -> Controller MergeStatus
customMergeToDir stb src dir = do
- src_exists <- doesFileExist src
- stb_exists <- doesFileExist stb
+ src_exists <- doIO $ doesFileExist src
+ stb_exists <- doIO $ doesFileExist stb
let outFile = joinPath [dir, src]
outDir = joinPath $ init $ splitDirectories outFile
outMod = concat $ intersperse "." $ splitDirectories $ dropExtension src
@@ -186,22 +160,22 @@ customMergeToDir stb src dir = do
(_, False) -> return $
MergeFailure ["Source file does not exist : "++stb]
_ -> do
- src_str <- readFile src
- stb_str <- readFile stb
+ src_str <- doIO $ readFile src
+ stb_str <- doIO $ readFile stb
let (stbimps, stbdecls) = span ( not . isPrefixOf "-- SPLIT HERE") $ lines stb_str
mrg_str = outTitle ++ (unlines stbimps) ++ src_str ++ (unlines stbdecls)
- createDirectoryIfMissing True outDir
- hdl <- openFile outFile WriteMode -- overwrite!
- hPutStr hdl mrg_str
- hClose hdl
+ doIO $ createDirectoryIfMissing True outDir
+ hdl <- doIO $ openFile outFile WriteMode -- overwrite!
+ doIO $ hPutStr hdl mrg_str
+ doIO $ hClose hdl
return $ MergeSuccess ReComp [] outFile -- must have recreated file
-needReloadCode :: Environment -> FilePath -> CodeDate -> IO Bool
-needReloadCode e fp fd = do
- fe <- doesFileExist fp
+needReloadCode :: FilePath -> CodeDate -> Controller Bool
+needReloadCode fp fd = do
+ fe <- doIO $ doesFileExist fp
case fe of
- True -> do mt <- getModificationTime fp
+ True -> do mt <- doIO $ getModificationTime fp
return $ mt > fd
False-> return True
View
27 Turbinado/Environment/Database.hs
@@ -0,0 +1,27 @@
+module Turbinado.Environment.Database (
+ addDatabaseToEnvironment,
+ Connection
+ ) where
+
+import Data.Typeable
+import Data.Dynamic
+import qualified Data.Map as M
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
+import Data.Maybe
+import qualified Database.HDBC as HDBC
+import Database.HDBC (IConnection)
+
+import Config.Master
+import Turbinado.Controller.Monad
+import Turbinado.Environment.Types
+
+
+addDatabaseToEnvironment :: Controller ()
+addDatabaseToEnvironment = do e <- get
+ case databaseConnection of
+ Nothing -> return ()
+ Just conn -> do c <- doIO $ conn
+ put $ e {getDatabase = Just c}
+
View
53 Turbinado/Environment/Logger.hs
@@ -3,34 +3,35 @@ module Turbinado.Environment.Logger where
import qualified System.Log.Logger as L
import qualified System.Log.Handler.Simple as S
import Control.Concurrent.MVar
-import Turbinado.Environment
+import Control.Monad.State
+import Control.Monad.Trans
+import Turbinado.Environment.Types
import Config.Master
import Data.Dynamic
-
-addLoggerToEnvironment :: EnvironmentFilter
-addLoggerToEnvironment e = do f <- S.fileHandler "log" logLevel
- L.updateGlobalLogger "Turbinado" ( L.setLevel logLevel . L.setHandlers [f])
- mv <- newMVar ()
- setLoggerLock mv e
-
-loggerKey = "logger"
-
-getLoggerLock :: Environment -> MVar ()
-getLoggerLock = getKey loggerKey
-
-setLoggerLock :: MVar () -> EnvironmentFilter
-setLoggerLock l = setKey loggerKey l
-
-takeLoggerLock :: Environment -> IO ()
-takeLoggerLock e = takeMVar (getLoggerLock e)
-
-putLoggerLock :: Environment -> IO ()
-putLoggerLock e = putMVar (getLoggerLock e) ()
-
-wrapLoggerLock :: (String -> IO ()) -> Environment -> String -> IO ()
-wrapLoggerLock lf e s = do takeLoggerLock e
- lf s
- putLoggerLock e
+import Data.Maybe
+import System.IO.Unsafe
+
+import Turbinado.Controller.Monad
+
+addLoggerToEnvironment :: Controller ()
+addLoggerToEnvironment = do e <- get
+ f <- doIO $ S.fileHandler "log" logLevel
+ doIO $ L.updateGlobalLogger "Turbinado" ( L.setLevel logLevel . L.setHandlers [f])
+ mv <- doIO $ newMVar ()
+ put $ e {getLoggerLock = Just mv}
+
+takeLoggerLock :: Controller ()
+takeLoggerLock = do e <- get
+ doIO $ takeMVar (fromJust $ getLoggerLock e)
+
+putLoggerLock :: Controller ()
+putLoggerLock = do e <- get
+ doIO $ putMVar (fromJust $ getLoggerLock e) ()
+
+wrapLoggerLock :: (String -> IO ()) -> String -> Controller ()
+wrapLoggerLock lf s = do takeLoggerLock
+ doIO $ lf s
+ putLoggerLock
debugM = wrapLoggerLock (L.logM "Turbinado" L.DEBUG)
infoM = wrapLoggerLock (L.logM "Turbinado" L.INFO)
View
31 Turbinado/Environment/MimeTypes.hs
@@ -32,8 +32,6 @@
-- -----------------------------------------------------------------------------
module Turbinado.Environment.MimeTypes (
- MimeTypes (..),
- getMimeTypes,
setMimeTypes,
mimeTypeOf,
addMimeTypesToEnvironment
@@ -44,23 +42,19 @@ import Data.Map (Map)
import Data.Typeable
import qualified Data.Map as Map hiding (Map)
import Text.ParserCombinators.Parsec
+import Control.Monad.State
+import Control.Monad.Trans
-import Turbinado.Environment
+import Turbinado.Environment.Types
-data MimeTypes = MimeTypes (Map String MimeType)
- deriving (Typeable)
-data MimeType = MimeType String String
+setMimeTypes :: MonadState Environment (mt Environment IO) => MimeTypes -> mt Environment IO ()
+setMimeTypes mi = do e <- get
+ put $ e {getMimeTypes = Just mi}
-instance Show MimeType where
- showsPrec _ (MimeType part1 part2) = showString (part1 ++ '/':part2)
-
-mimeTypesKey = "mimetypes"
-
-getMimeTypes :: Environment -> MimeTypes
-getMimeTypes = getKey mimeTypesKey
-
-setMimeTypes :: MimeTypes -> EnvironmentFilter
-setMimeTypes = setKey mimeTypesKey
+addMimeTypesToEnvironment :: (MonadState Environment (mt Environment IO), MonadIO (mt Environment IO)) => FilePath -> mt Environment IO ()
+addMimeTypesToEnvironment mime_types_file =
+ do stuff <- liftIO $ readFile mime_types_file
+ setMimeTypes (MimeTypes $ Map.fromList (parseMimeTypes stuff))
mimeTypeOf :: MimeTypes -> FilePath -> Maybe MimeType
@@ -76,11 +70,6 @@ extension fn = go (reverse fn) ""
go ('.':_) ext = ext
go (x:s) ext = go s (x:ext)
-addMimeTypesToEnvironment :: FilePath -> EnvironmentFilter
-addMimeTypesToEnvironment mime_types_file e =
- do stuff <- readFile mime_types_file
- setMimeTypes (MimeTypes $ Map.fromList (parseMimeTypes stuff)) e
-
parseMimeTypes :: String -> [(String,MimeType)]
parseMimeTypes file =
[ (ext,val)
View
132 Turbinado/Environment/Request.hs
@@ -1,138 +1,20 @@
module Turbinado.Environment.Request (
HTTP.Request(..),
addRequestToEnvironment,
- getRequest,
- setRequest,
- modifyRequest
- )where
+ ) where
import qualified Network.HTTP as HTTP
import Network.URI
import Turbinado.Utility.General
import qualified Data.Map as M
import Control.Monad
+import Control.Monad.State
import Data.Maybe
-import Turbinado.Environment
+import Turbinado.Environment.Types
+import Turbinado.Controller.Monad
-requestKey = "request"
+addRequestToEnvironment :: HTTP.Request -> Controller ()
+addRequestToEnvironment req = do e <- get
+ put $ e {getRequest = Just $ req}
-addRequestToEnvironment :: HTTP.Request -> EnvironmentFilter
-addRequestToEnvironment = setRequest
-getRequest :: Environment -> HTTP.Request
-getRequest = getKey requestKey
-
-setRequest :: HTTP.Request -> EnvironmentFilter
-setRequest req = setKey requestKey req
-
-modifyRequest :: (HTTP.Request -> HTTP.Request) -> EnvironmentFilter
-modifyRequest f = getRequest >>= (setRequest . f)
-
-{-
-lookupHeader :: (Monad m) => m (Maybe String)
-lookupHeader = liftM . lookupHeader
-
-lookupHeaderWithDefault :: (Monad m) => HTTP.Header -> String -> m String
-lookupHeaderWithDefault h s = do s' <- (liftM . lookupHeader) h
- case s' of
- Nothing -> s
- Just s'' -> s''
--}
-
-unEscape s = unEscapeString $ map (\ch -> if ch == '+' then ' ' else ch) s
-
---
--- * Environment variables
---
-
-{-
--- | Get the value of a Controller environment variable. Example:
---
--- > remoteAddr <- getVar "REMOTE_ADDR"
-getVar :: (Monad m) =>
- String -- ^ The name of the variable.
- -> m (Maybe String)
-getVar name = liftM (M.lookup name $ inputs)
-
-getVarWithDefault :: (Monad m) =>
- String -- ^ The name of the variable.
- -> String -- ^ Default value
- -> m String
-getVarWithDefault name def = liftM (fromMaybe def) $ getVar name
-
---
--- * Inputs
---
-
--- | Get the value of an input variable, for example from a form.
--- If the variable has multiple values, the first one is returned.
--- Example:
---
--- > query <- getInput "query"
-getInput :: (Monad m) =>
- String -- ^ The name of the variable.
- -> m (Maybe String) -- ^ The value of the variable,
- -- or Nothing, if it was not set.
-getInput v = lookup v `liftM` (request . getRequest)
-
--- | Like 'getInput', but returns a 'String'.
-getInputFPS :: (Monad m) =>
- String -- ^ The name of the variable.
- -> m (Maybe String) -- ^ The value of the variable,
- -- or Nothing, if it was not set.
-getInputFPS = liftM (fmap inputValue) . getInput_
-
-
--- | Get the value of an input variable or a default value if the
--- the input variable is not found.
--- Example:
---
--- > query <- getInput "somevariable" "defaultvalue"
-getInputWithDefault :: (Monad m) =>
- String -- ^ The name of the variable.
- -> String -- ^ The default value.
- -> m String -- ^ The value of the variable or default
-getInputWithDefault v s = do v' <- getInput v
- case v'
- of Nothing -> s
- Just s' -> s'
-
--- | Same as 'getInput', but tries to read the value to the desired type.
-readInput :: (Read a, Monad m) =>
- String -- ^ The name of the variable.
- -> m (Maybe a) -- ^ 'Nothing' if the variable does not exist
- -- or if the value could not be interpreted
- -- at the desired type.
-readInput = liftM (>>= maybeRead) . getInput
-
--- | Same as 'readInput', but with a default value.
-readInputWithDefault :: (Read a, Monad m) =>
- String -- ^ The name of the variable.
- -> a -- ^ The default value
- -> m (Maybe a) -- ^ 'Nothing' if the variable does not exist
- -- or if the value could not be interpreted
- -- at the desired type.
-readInputWithDefault v d = do v' <- liftM (>>= maybeRead) . getInput
- case v' of Nothing -> d
- Just v'' -> v''
-
--}
-
-{-
--- | Get the names and values of all inputs.
--- Note: the same name may occur more than once in the output,
--- if there are several values for the name.
-parseInputs :: (Monad m) => HTTP.Request -> m (M.Map String String)
-parseInputs r = do is <- r
- return M.fromList $ [ (n, inputValue i) | (n,i) <- is ]
-
--- Internal stuff
-
-getInput_ :: (Monad m) => String -> m (Maybe Input)
-getInput_ n = lookup n `liftM` getRequest
-
--- | Get the uninterpreted request body as a String
-getBody :: (Monad m) => m String
-getBody = liftM (HTTP.rqBody . httpRequest) getRequest
-
--}
View
139 Turbinado/Environment/Response.hs
@@ -1,7 +1,5 @@
module Turbinado.Environment.Response (
HTTP.Response,
- addResponseToEnvironment,
- getResponse,
setResponse,
isResponseComplete
)where
@@ -11,140 +9,19 @@ import Network.URI
import Turbinado.Utility.General
import qualified Data.Map as M
import Control.Monad
+import Control.Monad.State
import Data.Maybe
-import Turbinado.Environment
+import Turbinado.Environment.Types
import System.Time
import System.Locale
--- | Build a Response object given a parsed HTTP request.
-addResponseToEnvironment :: EnvironmentFilter
-addResponseToEnvironment e = do
- t <- getClockTime
- setResponse (HTTP.Response (0,0,0) "" (startingHeaders t) "") e
-
-startingHeaders t = [ HTTP.Header HTTP.HdrServer "Turbinado www.turbinado.org"
- , HTTP.Header HTTP.HdrContentType "text/html; charset=UTF-8"
- , HTTP.Header HTTP.HdrDate $ formatCalendarTime defaultTimeLocale rfc822DateFormat $ toUTCTime t
- ]
-
-responseKey = "response"
-
-getResponse :: Environment -> HTTP.Response
-getResponse = getKey responseKey
-
-setResponse :: HTTP.Response -> EnvironmentFilter
-setResponse = setKey responseKey
+setResponse :: MonadState Environment (mt Environment IO) => HTTP.Response -> mt Environment IO ()
+setResponse resp = do e <- get
+ put $ e {getResponse = Just resp}
isResponseComplete :: Environment -> Bool
-isResponseComplete e = let r = getResponse e
- in (HTTP.rspCode r /= (0,0,0))
-
-{-
-lookupHeader :: (Monad m) => m (Maybe String)
-lookupHeader = liftM . lookupHeader
-
-lookupHeaderWithDefault :: (Monad m) => HTTP.Header -> String -> m String
-lookupHeaderWithDefault h s = do s' <- (liftM . lookupHeader) h
- case s' of
- Nothing -> s
- Just s'' -> s''
--}
-
-unEscape s = unEscapeString $ map (\ch -> if ch == '+' then ' ' else ch) s
-
---
--- * Environment variables
---
-
-{-
--- | Get the value of a Controller environment variable. Example:
---
--- > remoteAddr <- getVar "REMOTE_ADDR"
-getVar :: (Monad m) =>
- String -- ^ The name of the variable.
- -> m (Maybe String)
-getVar name = liftM (M.lookup name $ inputs)
-
-getVarWithDefault :: (Monad m) =>
- String -- ^ The name of the variable.
- -> String -- ^ Default value
- -> m String
-getVarWithDefault name def = liftM (fromMaybe def) $ getVar name
-
---
--- * Inputs
---
-
--- | Get the value of an input variable, for example from a form.
--- If the variable has multiple values, the first one is returned.
--- Example:
---
--- > query <- getInput "query"
-getInput :: (Monad m) =>
- String -- ^ The name of the variable.
- -> m (Maybe String) -- ^ The value of the variable,
- -- or Nothing, if it was not set.
-getInput v = lookup v `liftM` (request . getRequest)
-
--- | Like 'getInput', but returns a 'String'.
-getInputFPS :: (Monad m) =>
- String -- ^ The name of the variable.
- -> m (Maybe String) -- ^ The value of the variable,
- -- or Nothing, if it was not set.
-getInputFPS = liftM (fmap inputValue) . getInput_
-
-
--- | Get the value of an input variable or a default value if the
--- the input variable is not found.
--- Example:
---
--- > query <- getInput "somevariable" "defaultvalue"
-getInputWithDefault :: (Monad m) =>
- String -- ^ The name of the variable.
- -> String -- ^ The default value.
- -> m String -- ^ The value of the variable or default
-getInputWithDefault v s = do v' <- getInput v
- case v'
- of Nothing -> s
- Just s' -> s'
-
--- | Same as 'getInput', but tries to read the value to the desired type.
-readInput :: (Read a, Monad m) =>
- String -- ^ The name of the variable.
- -> m (Maybe a) -- ^ 'Nothing' if the variable does not exist
- -- or if the value could not be interpreted
- -- at the desired type.
-readInput = liftM (>>= maybeRead) . getInput
-
--- | Same as 'readInput', but with a default value.
-readInputWithDefault :: (Read a, Monad m) =>
- String -- ^ The name of the variable.
- -> a -- ^ The default value
- -> m (Maybe a) -- ^ 'Nothing' if the variable does not exist
- -- or if the value could not be interpreted
- -- at the desired type.
-readInputWithDefault v d = do v' <- liftM (>>= maybeRead) . getInput
- case v' of Nothing -> d
- Just v'' -> v''
-
--}
-
-{-
--- | Get the names and values of all inputs.
--- Note: the same name may occur more than once in the output,
--- if there are several values for the name.
-parseInputs :: (Monad m) => HTTP.Request -> m (M.Map String String)
-parseInputs r = do is <- r
- return M.fromList $ [ (n, inputValue i) | (n,i) <- is ]
-
--- Internal stuff
-
-getInput_ :: (Monad m) => String -> m (Maybe Input)
-getInput_ n = lookup n `liftM` getRequest
-
--- | Get the uninterpreted request body as a String
-getBody :: (Monad m) => m String
-getBody = liftM (HTTP.rqBody . httpRequest) getRequest
+isResponseComplete e = case (getResponse e) of
+ Nothing -> False
+ Just r' -> (HTTP.rspCode r' /= (0,0,0))
--}
View
45 Turbinado/Environment/Routes.hs
@@ -12,7 +12,8 @@ import Control.Monad
import qualified Network.HTTP as HTTP
import qualified Network.URI as URI
import Turbinado.Controller.Exception
-import Turbinado.Environment
+import Turbinado.Controller.Monad
+import Turbinado.Environment.Types
import Turbinado.Environment.Logger
import Turbinado.Environment.Request
import Turbinado.Environment.Settings
@@ -20,45 +21,31 @@ import qualified Turbinado.Environment.Settings as S
import qualified Config.Routes
-type Keys = [String]
-data Routes = Routes [(Regex, Keys)]
- deriving (Typeable)
-
-routesKey = "routes"
-
-addRoutesToEnvironment :: EnvironmentFilter
-addRoutesToEnvironment = setRoutes $ Routes $ parseRoutes Config.Routes.routes
-
-getRoutes :: Environment -> Routes
-getRoutes = getKey routesKey
-
-setRoutes :: Routes -> EnvironmentFilter
-setRoutes = setKey routesKey
+addRoutesToEnvironment :: Controller ()
+addRoutesToEnvironment = do e <- get
+ put $ e {getRoutes = Just $ Routes $ parseRoutes Config.Routes.routes}
------------------------------------------------------------------------------
-- Given an Environment
------------------------------------------------------------------------------
-runRoutes :: EnvironmentFilter
-runRoutes e = do debugM e $ " Routes.runRoutes : starting"
- let Routes rs = getRoutes e
- r = getRequest e
+runRoutes :: Controller ()
+runRoutes = do debugM $ " Routes.runRoutes : starting"
+ e <- get
+ let Routes rs = fromJust $ getRoutes e
+ r = fromJust $ getRequest e
p = URI.uriPath $ HTTP.rqURI r
sets = msum $ map (\(r, k) -> maybe [] (zip k) (matchRegex r p)) rs
- debugM e $ " Routes.runRoutes : checking sets"
case sets of
[] -> throwController $ ParameterLookupFailed $ "No routes matched for " ++ p
- _ -> do debugM e $ " Routes.foldl"
- debugM e $ " Routes : keys = " ++ (concat $ M.keys $ getSettings e)
- e' <- foldl (\m (k, v) -> m >>= setSetting k v) (return e) sets
- debugM e $ " Routes : keys = " ++ (concat $ M.keys $ getSettings e')
- debugM e $ " Routes.addDefaultAction"
- addDefaultAction e'
+ _ -> do mapM (\(k, v) -> setSetting k v) sets
+ addDefaultAction
-addDefaultAction :: EnvironmentFilter
-addDefaultAction e = do let s = getSettings e
- setSettings (M.insertWith (\ a b -> b) "action" (toDyn "Index") s) e
+addDefaultAction :: Controller ()
+addDefaultAction = do e <- get
+ let s = fromJust $ getSettings e
+ put $ e {getSettings = Just (M.insertWith (\ a b -> b) "action" (toDyn "Index") s)}
------------------------------------------------------------------------------
-- Generate the Routes from [String]
View
63 Turbinado/Environment/Settings.hs
@@ -1,9 +1,8 @@
module Turbinado.Environment.Settings (
addSettingsToEnvironment,
getSetting,
+ getSetting_u,
setSetting,
- getSettings,
- setSettings,
getController,
clearLayout,
getLayout,
@@ -17,53 +16,47 @@ import Control.Monad.State
import Data.Maybe
import Data.Char
import System.FilePath
-import Turbinado.Environment
+import Turbinado.Environment.Types
+import Turbinado.Controller.Monad
-type Settings = M.Map String Dynamic
-
-
-settingsKey = "settings"
-
-addSettingsToEnvironment :: EnvironmentFilter
-addSettingsToEnvironment = setSettings (M.fromList defaultSettings :: Settings)
-
-getSettings :: Environment -> Settings
-getSettings = getKey settingsKey
-
-setSettings :: Settings -> EnvironmentFilter
-setSettings = setKey settingsKey
+addSettingsToEnvironment :: Controller ()
+addSettingsToEnvironment = do e <- get
+ put $ e {getSettings = Just $ M.fromList defaultSettings }
------------------------------------------------------------------
-- Set/Get an individual settting
------------------------------------------------------------------
-getSetting :: (Typeable a) => String -> Environment -> Maybe a
-getSetting s e = maybe Nothing (fromDynamic) ( M.lookup s (getKey settingsKey e) )
+getSetting :: Typeable a => String -> Controller (Maybe a)
+getSetting s = do e <- get
+ return $ maybe Nothing (fromDynamic) ( M.lookup s (fromJust $ getSettings e) )
-getSetting_u :: (Typeable a) => String -> Environment -> a
-getSetting_u s e = fromJust (getSetting s e)
+getSetting_u s = getSetting s >>= \v -> return (fromJust v)
-setSetting :: (Typeable a) => String -> a -> EnvironmentFilter
-setSetting k v e = do let settings = getSettings e
- setSettings (M.insert k (toDyn v) settings) e
+setSetting :: (Typeable a) => String -> a -> Controller ()
+setSetting k v = do e <- get
+ put $ e { getSettings = Just (M.insert k (toDyn v) (fromJust $ getSettings e))}
defaultSettings = [ ("layout", toDyn "Default") ]
------------------------------------------------------------------
-- Shorthands
------------------------------------------------------------------
-getController :: Environment -> (FilePath, String)
-getController e = ( fromJust $ getSetting "controller" e,
- actionName $ fromJust $ getSetting "action" e)
- where actionName s = (toLower $ head s) : (tail s)
-
-clearLayout :: EnvironmentFilter
+getController :: Controller (FilePath, String)
+getController = do e <- get
+ c <- getSetting "controller"
+ a <- getSetting "action"
+ return $ (fromJust c,
+ actionName $ fromJust a)
+ where actionName s = (toLower $ head s) : (tail s)
+
+clearLayout :: Controller ()
clearLayout = setSetting "layout" ""
-getLayout :: Environment -> (FilePath, String)
-getLayout e = (fromJust $ getSetting "layout" e, "page")
+getLayout :: Controller (FilePath, String)
+getLayout = (\l -> return (fromJust l, "page")) =<< getSetting "layout"
-getView :: Environment -> (FilePath, String)
-getView e = let c = fromJust $ getSetting "controller" e
- a = fromJust $ getSetting "action" e
- in (joinPath $ map normalise [c,a], "page")
+getView :: Controller (FilePath, String)
+getView = do c <- getSetting_u "controller"
+ a <- getSetting_u "action"
+ return (joinPath $ map normalise [c,a], "page")
View
118 Turbinado/Environment/Types.hs
@@ -0,0 +1,118 @@
+module Turbinado.Environment.Types where
+
+import Data.Dynamic
+import qualified Data.Map as M
+import Data.Maybe
+import System.IO
+import System.IO.Unsafe
+import System.Log.Logger
+import Text.Regex
+import Control.Concurrent.MVar
+import Control.Monad.State
+import qualified Network.HTTP as HTTP
+import HSX.XMLGenerator (XMLGenT(..), unXMLGenT)
+import Turbinado.View.XML
+import Config.Master
+import System.Time
+import System.Plugins
+
+-- Stuffing all Environment "types" into this file to avoid
+-- recursive imports...
+
+data Environment = Environment { getCodeStore :: Maybe CodeStore
+ , getDatabase :: Maybe Database
+ , getLoggerLock :: Maybe LoggerLock
+ , getMimeTypes :: Maybe MimeTypes
+ , getRequest :: Maybe HTTP.Request
+ , getResponse :: Maybe HTTP.Response
+ , getRoutes :: Maybe Routes
+ , getSettings :: Maybe Settings
+ , getViewData :: Maybe ViewData
+ , getAppEnvironment :: Maybe AppEnvironment
+ }
+
+-- type EnvironmentFilter = Environment -> IO Environment
+
+newEnvironment :: Environment
+newEnvironment = Environment { getCodeStore = Nothing
+ , getDatabase = Nothing
+ , getLoggerLock = Nothing
+ , getMimeTypes = Nothing
+ , getRequest = Nothing
+ , getResponse = Nothing
+ , getRoutes = Nothing
+ , getSettings = Nothing
+ , getViewData = Nothing
+ , getAppEnvironment = Nothing
+ }
+
+--
+-- * Types for CodeStore
+--
+
+data CodeType = CTView | CTController | CTLayout
+type CodeDate = ClockTime
+type Function = String
+type CodeLocation = (FilePath, Function)
+
+data CodeStore = CodeStore (MVar CodeMap)
+type CodeMap = M.Map CodeLocation CodeStatus
+data CodeStatus = CodeLoadFailure |
+ CodeLoadController (StateT Environment IO ()) Module CodeDate |
+ CodeLoadView (XMLGenT (StateT Environment IO) XML ) Module CodeDate
+
+--
+-- * Types for Database
+--
+
+type Database = Connection
+
+
+--
+-- * Types for Logger
+--
+
+type LoggerLock = MVar ()
+
+
+--
+-- * Types for MimeTypes
+--
+
+data MimeTypes = MimeTypes (M.Map String MimeType)
+data MimeType = MimeType String String
+
+instance Show MimeType where
+ showsPrec _ (MimeType part1 part2) = showString (part1 ++ '/':part2)
+
+--
+-- * Types for Request
+--
+
+-- Just a basic Request from Network.HTTP
+
+--
+-- * Types for Response
+--
+
+-- Just a basic Response from Network.HTTP
+
+--
+-- * Types for Routes
+--
+
+type Keys = [String]
+data Routes = Routes [(Regex, Keys)]
+
+--
+-- * Types for Settings
+--
+
+type Settings = M.Map String Dynamic
+
+--
+-- * Types for ViewData
+--
+
+type ViewData = M.Map String Dynamic
+
View
50 Turbinado/Environment/ViewData.hs
@@ -1,27 +1,37 @@
module Turbinado.Environment.ViewData (
addViewDataToEnvironment,
- getViewData,
- setViewData
+ getViewDataValue,
+ getViewDataValue_u,
+ setViewDataValue
)where
import qualified Data.Map as M
import Control.Monad
+import Control.Monad.Trans
import Data.Maybe
-import Turbinado.Environment
-
-type ViewData = Map String Dynamic
-
-
-viewDataKey = "viewdata"
-
-addViewDataToEnvironment :: EnvironmentFilter
-addViewDataToEnvironment = setViewData (empty :: ViewData)
-
-getViewData :: Environment -> ViewData
-getViewData = getKey viewDataKey
-
-setViewData :: ViewData -> EnvironmentFilter
-setViewData vd = setKey viewDataKey vd
-
-getViewDataValue :: (Typeable a) => String -> Environment -> a
-getViewDataValue s e = lookup (getViewData e) s
+import Data.Typeable
+import Data.Dynamic
+
+import Turbinado.Environment.Types
+import Turbinado.Controller.Monad
+import Turbinado.View.Monad
+
+addViewDataToEnvironment :: Controller ()
+addViewDataToEnvironment = do e <- get
+ put $ e {getViewData = Just (M.empty :: ViewData)}
+
+getViewDataValue :: (Typeable a) => String -> View (Maybe a)
+getViewDataValue k = do e <- lift get
+ case (M.lookup k $ fromJust $ getViewData e) of
+ Nothing -> return $ Nothing
+ Just l -> return $ fromDynamic l
+
+getViewDataValue_u :: (Typeable a) => String -> View a
+getViewDataValue_u k = do v <- getViewDataValue k
+ return $ fromJust v
+
+setViewDataValue :: (Typeable a) => String -> a -> Controller ()
+setViewDataValue k v = do e <- get
+ let vd = fromJust $ getViewData e
+ vd' = M.insert k (toDyn v) vd
+ put $ e {getViewData = Just vd'}
View
40 Turbinado/Server.hs
@@ -21,12 +21,17 @@ import qualified Network.URI as URI
import Config.Master
-import Turbinado.Environment
+import Turbinado.Controller.Monad hiding (catch)
+import Turbinado.Environment.Database
+import Turbinado.Environment.Logger
+import Turbinado.Environment.MimeTypes
import Turbinado.Environment.Request
import Turbinado.Environment.Response
import Turbinado.Environment.Routes
import Turbinado.Environment.Settings
-import Turbinado.Environment.CodeStore (addCodeStoreToEnvironment, CodeStore)
+import Turbinado.Environment.Types
+import Turbinado.Environment.ViewData
+import Turbinado.Environment.CodeStore (addCodeStoreToEnvironment)
import Turbinado.Server.Exception
import Turbinado.Server.Handlers.ErrorHandler (handleError, handleTurbinado)
import Turbinado.Server.Handlers.RequestHandler (requestHandler)
@@ -34,8 +39,6 @@ import Turbinado.Server.Handlers.SessionHandler
import Turbinado.Server.Network (receiveRequest, sendResponse)
import Turbinado.Server.StandardResponse (pageResponse)
import Turbinado.Server.StaticContent
-import Turbinado.Environment.Logger
-import Turbinado.Environment.MimeTypes
data Flag
= Port Integer
@@ -63,13 +66,11 @@ main =
startServer :: PortNumber -> IO ()
startServer pnr
= withSocketsDo $
- do e <- foldl (>>=) newEnvironment [ addLoggerToEnvironment,
- addCodeStoreToEnvironment
- , addMimeTypesToEnvironment "Config/mime.types"]
- debugM e "Start listening"
+ do e <- runController (sequence_ [ addLoggerToEnvironment
+ , addCodeStoreToEnvironment
+ , addMimeTypesToEnvironment "Config/mime.types"]) newEnvironment
sock <- listenOn $ PortNumber pnr
workerPoolMVar <- newMVar $ WorkerPool 0 [] []
- debugM e "Need to fork off the threadKillerLoop"
mainLoop sock workerPoolMVar e
where
--mainLoop :: Socket -> WorkerPool -> IO ()
@@ -92,9 +93,7 @@ workerLoop workerPoolMVar e chan
= do mainLoop
where
mainLoop
- = do -- debugM e "Wait for requests"
- sock <- readChan chan
- -- getClockTime >>= (\t -> debugM e $ "Received request @ " ++ (show $ toUTCTime t))
+ = do sock <- readChan chan
handleRequest sock e
putWorkerThread workerPoolMVar chan
mainLoop
@@ -102,12 +101,11 @@ workerLoop workerPoolMVar e chan
handleRequest :: Socket -> Environment -> IO ()
handleRequest sock e
= (do mytid <- myThreadId
- e' <- foldl ( >>= ) (return e) [ addSettingsToEnvironment
- , addResponseToEnvironment
+ e' <- runController (sequence_ [ addViewDataToEnvironment
+ , addSettingsToEnvironment
, receiveRequest sock
, tryStaticContent
- , addRoutesToEnvironment ]
- -- debugM e $ "Handling Request : " ++ (URI.uriPath $ HTTP.rqURI $ getRequest e')
+ , addRoutesToEnvironment ]) e
case (isResponseComplete e') of
True -> sendResponse sock e'
False -> do e'' <- requestHandler e'
@@ -134,23 +132,21 @@ getWorkerThread mv e =
do wp <- takeMVar mv
case wp of
WorkerPool n [] bs ->
- do debugM e "Making new worker thread"
- chan <- newChan
- tid <- forkIO $ workerLoop mv e chan
+ do chan <- newChan
+ e' <- runController (addDatabaseToEnvironment) e
+ tid <- forkIO $ workerLoop mv e' chan
let workerThread = WorkerThread tid chan
expiresTime <- getCurrentTime >>= \utct -> return $ addUTCTime (fromInteger stdTimeOut) utct
putMVar mv $ WorkerPool (n+1) [] ((workerThread, expiresTime):bs)
return workerThread
WorkerPool n (idle:idles) busies ->
- do -- debugM e ("Using existing worker thread (" ++ (show $ length ([idle] ++ idles )) ++ ", " ++ (show $ length busies) ++ ")")
- expiresTime <- getCurrentTime >>= \utct -> return $ addUTCTime (fromInteger stdTimeOut) utct
+ do expiresTime <- getCurrentTime >>= \utct -> return $ addUTCTime (fromInteger stdTimeOut) utct
putMVar mv $ WorkerPool n idles ((idle, expiresTime):busies)
return idle
putWorkerThread mv chan = do
WorkerPool n is bs <- takeMVar mv
mytid <- myThreadId
- -- getClockTime >>= (\t -> debugM e ("Adding me back to the WorkerPool (" ++ (show $ length is) ++ ", " ++ (show $ length bs) ++ ") @ " ++ (show $ toUTCTime t)) )
let bs' = filter (\(WorkerThread tid _, _) -> tid /= mytid) bs
putMVar mv $ WorkerPool n ((WorkerThread mytid chan):is) bs'
View
48 Turbinado/Server/Handlers/ErrorHandler.hs
@@ -5,7 +5,8 @@ import Prelude hiding (catch)
import Data.Dynamic ( fromDynamic )
import Network.Socket
-import Turbinado.Environment
+import Turbinado.Controller.Monad
+import Turbinado.Environment.Types
import Turbinado.Environment.Response
import Turbinado.Server.Exception
import Turbinado.Server.Network
@@ -14,31 +15,32 @@ import Turbinado.Server.StandardResponse
--import Turbinado.PrintDebug
handleError :: Socket -> Exception -> Environment -> IO ()
-handleError s ex e = do e' <- errorResponse err e
+handleError s ex e = do e' <- runController (errorResponse err) e
sendResponse s e'
where err = unlines [ "Error in server: " ++ show ex
- ," please report as a bug to d00nibro@licia.dtek.chalmers.se"]
+ ," please report as a bug to alson@alsonkemp.com"]
handleTurbinado :: Socket -> TurbinadoException -> Environment -> IO ()
handleTurbinado s he e = do
- case he of
- CompilationFailed errs -> sendResponse s =<< (errorResponse err e)
- where err = unlines $ "File did not compile:" : errs
- FileNotFound file -> sendResponse s =<< (fileNotFoundResponse file e)
- LoadApplicationFailed dir -> sendResponse s =<< (errorResponse err e)
- where err = "Failed to load application file in directory " ++ dir
- AppCompilationFailed errs -> sendResponse s =<< (errorResponse err e)
- where err = unlines $ "Application file did not compile:" : errs
- NoURISpecified -> sendResponse s =<< (badReqResponse e)
- TimedOut -> sendResponse s =<< (errorResponse err e)
- where err = "Evaluation timed out"
- BadRequest _ -> sendResponse s =<< (badReqResponse e)
- PageEvalFailed ex -> sendResponse s =<< (errorResponse err e)
- where err = "An exception occured during page evaluation\n:" ++
- case ex of
- DynException dyn ->
- case (fromDynamic dyn :: Maybe Exception) of
- Nothing -> show ex
- Just hspe -> show hspe
- _ -> show ex
+ e' <- runController (case he of
+ CompilationFailed errs -> errorResponse err
+ where err = unlines $ "File did not compile:" : errs
+ FileNotFound file -> fileNotFoundResponse file
+ LoadApplicationFailed dir -> errorResponse err
+ where err = "Failed to load application file in directory " ++ dir
+ AppCompilationFailed errs -> errorResponse err
+ where err = unlines $ "Application file did not compile:" : errs
+ NoURISpecified -> badReqResponse
+ TimedOut -> errorResponse err
+ where err = "Evaluation timed out"
+ BadRequest _ -> badReqResponse
+ PageEvalFailed ex -> errorResponse err
+ where err = "An exception occured during page evaluation\n:" ++
+ case ex of
+ DynException dyn ->
+ case (fromDynamic dyn :: Maybe Exception) of
+ Nothing -> show ex
+ Just hspe -> show hspe
+ _ -> show ex) e
+ sendResponse s e'
View
88 Turbinado/Server/Handlers/RequestHandler.hs
@@ -29,7 +29,7 @@ import Data.List
import Data.Dynamic
import Config.Master
-import Turbinado.Environment
+import Turbinado.Environment.Types
import Turbinado.Environment.CodeStore
import Turbinado.Environment.Logger
import Turbinado.Environment.Request
@@ -41,69 +41,51 @@ import Turbinado.View
import Turbinado.View.XML
import Turbinado.Server.StandardResponse
-preFilters :: [EnvironmentFilter]
+preFilters :: [Controller ()]
preFilters = [Routes.runRoutes ]
-postFilters :: [EnvironmentFilter]
+postFilters :: [Controller ()]
postFilters = []
-requestHandler :: EnvironmentFilter
-requestHandler e = do
- debugM e $ " requestHandler : running pre and main filters"
+requestHandler :: Environment -> IO Environment
+requestHandler e = runController requestHandler' e
+
+requestHandler' :: Controller ()
+requestHandler' = do
+ debugM $ " requestHandler : running pre and main filters"
-- Run the Pre filters, the page
- e' <- foldl ( chainer ) (return e) $ preFilters ++
- customPreFilters ++
- [ retrieveAndRunController
- , retrieveAndRunLayout
- ]
- debugM e $ " requestHandler : running post filters"
- foldl ( >>= ) (return e') (customPostFilters ++ postFilters)
+ sequence_ $ preFilters ++
+ customPreFilters ++
+ [ retrieveAndRunController
+ , retrieveAndRunLayout
+ ]
+ debugM $ " requestHandler : running post filters"
+ sequence_ (customPostFilters ++ postFilters)
--- chains EnvironmentFilters together, skipping the
--- remaining filters if the Response is complete
-chainer :: IO Environment -> EnvironmentFilter -> IO Environment
-chainer m f = do e <- m
- case isResponseComplete e of
- True -> return e
- False -> f e
-
-retrieveAndRunController :: EnvironmentFilter
-retrieveAndRunController e =
- do debugM e $ " retrieveAndRunController : Starting"
- debugM e $ " retrieveAndRunController : c = " ++ (show $ (getSetting "controller" e :: Maybe String))
- debugM e $ " retrieveAndRunController : a = " ++ (show $ (getSetting "action" e :: Maybe String))
- let c = fromJust $ getSetting "controller" e -- FIXME: handle the Maybe (!fromJust)
- a = fromJust $ getSetting "action" e
- debugM e $ " retrieveAndRunController : " ++ c ++ " : " ++ a
- p <- retrieveCode e CTController (getController e)
+retrieveAndRunController :: Controller ()
+retrieveAndRunController =
+ do debugM $ " retrieveAndRunController : Starting"
+ c <- getSetting_u "controller"
+ a <- getSetting_u "action"
+ debugM $ " retrieveAndRunController : " ++ c ++ " : " ++ a
+ co <- getController
+ p <- retrieveCode CTController co
case p of
- CodeLoadController p' _ _ -> evalController p' e
+ CodeLoadController p' _ _ -> p'
CodeLoadView _ _ _ -> error "retrieveAndRunView called, but returned CodeLoadView"
- CodeLoadFailure -> fileNotFoundResponse c e
+ CodeLoadFailure -> fileNotFoundResponse c
-retrieveAndRunLayout :: EnvironmentFilter
-retrieveAndRunLayout e =
- do let l = getLayout e -- FIXME: handle the Maybe (!fromJust)
+retrieveAndRunLayout :: Controller ()
+retrieveAndRunLayout =
+ do l <- getLayout
p <- case l of
- ("", _) -> retrieveCode e CTView (getView e) -- If no Layout, then pull a View
- _ -> retrieveCode e CTLayout l
+ ("", _) -> do v <- getView
+ retrieveCode CTView v -- If no Layout, then pull a View
+ _ -> retrieveCode CTLayout l
case p of
- CodeLoadView p' _ _ -> evalView p' e
+ CodeLoadView p' _ _ -> evalView p'
CodeLoadController _ _ _ -> error "retrieveAndRunLayout called, but returned CodeLoadController"
- CodeLoadFailure -> fileNotFoundResponse (joinPath [(fst l), (snd l)]) e
+ CodeLoadFailure -> fileNotFoundResponse (joinPath [(fst l), (snd l)])
+
-{-
-baseRequestHandler :: HTTP.Request -> CodeStore -> SessionStore -> IO HTTP.Response
-baseRequestHandler hreq pages sst = do
- debugM e "Done!"