Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

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

… ORM
  • Loading branch information...
commit 1e33cd063a9b40de72003c465fa1363f05bc882e 1 parent d64e562
@alsonkemp authored
Showing with 339 additions and 264 deletions.
  1. +2 −0  Config/App.hs.sample
  2. +7 −4 Config/Master.hs
  3. +4 −5 Turbinado/Controller.hs
  4. +5 −6 Turbinado/Controller/Monad.hs
  5. +57 −26 Turbinado/Database/ORM/Output.hs
  6. +77 −52 Turbinado/Environment/CodeStore.hs
  7. +4 −4 Turbinado/Environment/Database.hs
  8. +2 −2 Turbinado/Environment/Header.hs
  9. +22 −15 Turbinado/Environment/Logger.hs
  10. +4 −4 Turbinado/Environment/MimeTypes.hs
  11. +6 −7 Turbinado/Environment/Params.hs
  12. +3 −4 Turbinado/Environment/Request.hs
  13. +3 −3 Turbinado/Environment/Response.hs
  14. +8 −9 Turbinado/Environment/Routes.hs
  15. +15 −15 Turbinado/Environment/Settings.hs
  16. +10 −3 Turbinado/Environment/Types.hs
  17. +9 −11 Turbinado/Environment/ViewData.hs
  18. +3 −3 Turbinado/Layout.hs
  19. +8 −3 Turbinado/Server.hs
  20. +6 −10 Turbinado/Server/Handlers/RequestHandler.hs
  21. +1 −1  Turbinado/Server/Network.hs
  22. +12 −12 Turbinado/Server/StandardResponse.hs
  23. +3 −3 Turbinado/Server/StaticContent.hs
  24. +6 −0 Turbinado/Stubs/ComponentController.hs
  25. +8 −0 Turbinado/Stubs/ComponentView.hs
  26. +1 −2  Turbinado/Stubs/Layout.hs
  27. +1 −1  Turbinado/Stubs/View.hs
  28. +38 −53 Turbinado/View.hs
  29. +14 −6 Turbinado/View/Monad.hs
View
2  Config/App.hs.sample
@@ -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
11 Config/Master.hs
@@ -18,7 +18,7 @@ compileArgs =
, "-odir " ++ compiledDir
, "-hidir " ++ compiledDir
, "-package HDBC"
- ] ++ (map ("-i"++) searchDirs)
+ ]
mUserPkgConf = [""]
@@ -26,16 +26,19 @@ 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
9 Turbinado/Controller.hs
@@ -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
View
11 Turbinado/Controller/Monad.hs
@@ -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
View
83 Turbinado/Database/ORM/Output.hs
@@ -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,7 +93,7 @@ generateModelBase = unlines $
,"import Database.HDBC"
,"import Data.Int"
,""
- ,"import Turbinado.Controller.Monad"
+ ,"import Turbinado.Environment.Types"
,""
,"-- Using phantom types here "
,"class DatabaseModel m where"
@@ -97,18 +101,23 @@ generateModelBase = unlines $
,""
,"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)
View
129 Turbinado/Environment/CodeStore.hs
@@ -26,25 +26,25 @@ import Turbinado.Environment.Logger
import Turbinado.Environment.Types
import Turbinado.Environment.Request
import Turbinado.Environment.Response
-import Turbinado.View.Monad hiding (doIO)
+import Turbinado.View.Monad hiding (liftIO)
import Turbinado.View.XML
import Turbinado.Controller.Monad
-- | Create a new store for Code data
-addCodeStoreToEnvironment :: Controller ()
-addCodeStoreToEnvironment = do e <- get
- mv <- doIO $ newMVar $ empty
- put $ e {getCodeStore = Just $ CodeStore mv}
+addCodeStoreToEnvironment :: (HasEnvironment m) => m ()
+addCodeStoreToEnvironment = do e <- getEnvironment
+ mv <- liftIO $ newMVar $ empty
+ setEnvironment $ e {getCodeStore = Just $ CodeStore mv}
-retrieveCode :: CodeType -> CodeLocation -> Controller CodeStatus
+retrieveCode :: (HasEnvironment m) => CodeType -> CodeLocation -> m CodeStatus
retrieveCode ct cl' = do
- e <- get
+ e <- getEnvironment
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 $ " CodeStore : retrieveCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
- cmap <- doIO $ takeMVar mv
+ cmap <- liftIO $ takeMVar mv
let c= lookup cl cmap
cmap' <- case c of
Nothing -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : fresh load")
@@ -53,42 +53,50 @@ retrieveCode ct cl' = do
loadCode ct cmap cl
_ -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : checking reload")
checkReloadCode ct cmap (fromJust c) cl
- doIO $ putMVar mv cmap'
+ liftIO $ 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 (fst cl ++ " : Not found in CodeStore")
- return (CodeLoadFailure (fst cl ++ " : Not found in CodeStore") )
+ return CodeLoadMissing
+ Just CodeLoadMissing -> do debugM (fst cl ++ " : Not found in CodeStore")
+ return CodeLoadMissing
Just (CodeLoadFailure e) -> do debugM (fst cl ++ " : CodeLoadFailure " )
return (CodeLoadFailure e)
Just clc@(CodeLoadController _ _ _) -> do debugM (fst cl ++ " : CodeLoadController " )
return clc
Just clv@(CodeLoadView _ _ _) -> do debugM (fst cl ++ " : CodeLoadView" )
return clv
+ Just clc@(CodeLoadComponentController _ _ _) -> do debugM (fst cl ++ " : CodeLoadComponentController " )
+ return clc
+ Just clv@(CodeLoadComponentView _ _ _) -> do debugM (fst cl ++ " : CodeLoadComponentView" )
+ return clv
-checkReloadCode :: CodeType -> CodeMap -> CodeStatus -> CodeLocation -> Controller CodeMap
+checkReloadCode :: (HasEnvironment m) => CodeType -> CodeMap -> CodeStatus -> CodeLocation -> m CodeMap
checkReloadCode ct cmap (CodeLoadFailure e) 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 $ " CodeStore : checkReloadCode : No reload neeeded"
+ (exists, reload) <- needReloadCode (fst cl) (getDate cstat)
+ case (exists, reload) of
+ (False, _) -> do debugM $ " CodeStore : checkReloadCode : Code missing"
+ return $ insert cl CodeLoadMissing cmap
+ (True, False) -> do debugM $ " CodeStore : checkReloadCode : No reload neeeded"
return cmap
- True -> do debugM $ " CodeStore : checkReloadCode : Need reload"
+ (True, 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 :: CodeType -> CodeMap -> CodeLocation -> Controller CodeMap
+loadCode :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> m CodeMap
loadCode ct cmap cl = do
debugM $ "\tCodeStore : loadCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
- fe <- doIO $ doesFileExist $ fst cl
+ fe <- liftIO $ doesFileExist $ fst cl
case fe of
False -> debugM ("\tFile not found: " ++ fst cl) >> return cmap
True -> mergeCode ct cmap cl
-mergeCode :: CodeType -> CodeMap -> CodeLocation -> Controller CodeMap
+mergeCode :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> m CodeMap
mergeCode ct cmap cl = do
debugM $ "\tMerging " ++ (fst cl)
-- d <- getCurrentDirectory
@@ -102,9 +110,9 @@ mergeCode ct cmap cl = do
MergeSuccess _ args fp -> do debugM ("\tMerge success : " ++ (fst cl))
makeCode ct cmap cl args fp
-makeCode :: CodeType -> CodeMap -> CodeLocation -> [Arg] -> FilePath -> Controller CodeMap
+makeCode :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> [Arg] -> FilePath -> m CodeMap
makeCode ct cmap cl args fp = do
- ms <- doIO $ makeAll fp (compileArgs++args)
+ ms <- liftIO $ makeAll fp (compileArgs++args)
case ms of
MakeFailure err -> do debugM ("\tMake error : " ++ (show err))
return (insert cl (CodeLoadFailure $ unlines err) cmap)
@@ -112,32 +120,42 @@ makeCode ct cmap cl args fp = do
return cmap
MakeSuccess _ fp -> do debugM ("\tMake success : " ++ fp)
case ct of
+ CTLayout -> _loadView ct cmap cl fp
+ CTView -> _loadView ct cmap cl fp
+ CTComponentView -> _loadView ct cmap cl fp
CTController -> _loadController ct cmap cl fp
- _ -> _loadView ct cmap cl fp
+ CTComponentController -> _loadController ct cmap cl fp
-_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)
+_loadView :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> FilePath -> m CodeMap
+_loadView ct cmap cl fp = do
+ debugM ("_load : " ++ (show ct) ++ " : " ++ (fst cl) ++ " : " ++ (snd cl))
+ ls <- liftIO $ load_ fp [compiledDir] (snd cl)
case ls of
LoadFailure err -> do debugM ("LoadFailure : " ++ (show err))
return (insert cl (CodeLoadFailure $ unlines err) cmap)
LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
- doIO $ unload m
- t <- doIO $ getClockTime
- return (insert cl (CodeLoadController f m t) cmap)
-
-_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)
+ liftIO $ unload m
+ t <- liftIO $ getClockTime
+ case ct of
+ CTLayout -> return (insert cl (CodeLoadView f m t) cmap)
+ CTView -> return (insert cl (CodeLoadView f m t) cmap)
+ CTComponentView -> return (insert cl (CodeLoadComponentView f m t) cmap)
+ _ -> error $ "_loadView: passed an invalid CodeType (" ++ (show ct) ++ ")"
+
+_loadController :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> FilePath -> m CodeMap
+_loadController ct cmap cl fp = do
+ debugM ("_load : " ++ (show ct) ++ " : " ++ (fst cl) ++ " : " ++ (snd cl))
+ ls <- liftIO $ load_ fp [compiledDir] (snd cl)
case ls of
- LoadFailure err -> do debugM ("\tLoadFailure : " ++ (show err))
+ LoadFailure err -> do debugM ("LoadFailure : " ++ (show err))
return (insert cl (CodeLoadFailure $ unlines err) cmap)
- LoadSuccess m f -> do debugM ("\tLoadSuccess : " ++ fst cl )
- doIO $ unload m
- t <- doIO $ getClockTime
- return (insert cl (CodeLoadView f m t) cmap)
+ LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
+ liftIO $ unload m
+ t <- liftIO $ getClockTime
+ case ct of
+ CTController -> return (insert cl (CodeLoadController f m t) cmap)
+ CTComponentController -> return (insert cl (CodeLoadComponentController f m t) cmap)
+ _ -> error $ "_loadController: passed an invalid CodeType (" ++ (show ct) ++ ")"
-------------------------------------------------------------------------------------------------
@@ -146,10 +164,10 @@ _loadView 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 -> Controller MergeStatus
+customMergeToDir :: (HasEnvironment m) => FilePath -> FilePath -> FilePath -> m MergeStatus
customMergeToDir stb src dir = do
- src_exists <- doIO $ doesFileExist src
- stb_exists <- doIO $ doesFileExist stb
+ src_exists <- liftIO $ doesFileExist src
+ stb_exists <- liftIO $ doesFileExist stb
let outFile = joinPath [dir, src]
outDir = joinPath $ init $ splitDirectories outFile
outMod = concat $ intersperse "." $ splitDirectories $ dropExtension src
@@ -160,24 +178,24 @@ customMergeToDir stb src dir = do
(_, False) -> return $
MergeFailure ["Source file does not exist : "++stb]
_ -> do
- src_str <- doIO $ readFile src
- stb_str <- doIO $ readFile stb
+ src_str <- liftIO $ readFile src
+ stb_str <- liftIO $ readFile stb
let (stbimps, stbdecls) = span ( not . isPrefixOf "-- SPLIT HERE") $ lines stb_str
mrg_str = outTitle ++ (unlines stbimps) ++ src_str ++ (unlines stbdecls)
- doIO $ createDirectoryIfMissing True outDir
- hdl <- doIO $ openFile outFile WriteMode -- overwrite!
- doIO $ hPutStr hdl mrg_str
- doIO $ hClose hdl
+ liftIO $ createDirectoryIfMissing True outDir
+ hdl <- liftIO $ openFile outFile WriteMode -- overwrite!
+ liftIO $ hPutStr hdl mrg_str
+ liftIO $ hClose hdl
return $ MergeSuccess ReComp [] outFile -- must have recreated file
-needReloadCode :: FilePath -> CodeDate -> Controller Bool
+needReloadCode :: (HasEnvironment m) => FilePath -> CodeDate -> m (Bool, Bool)
needReloadCode fp fd = do
- fe <- doIO $ doesFileExist fp
+ fe <- liftIO $ doesFileExist fp
case fe of
- True -> do mt <- doIO $ getModificationTime fp
- return $ mt > fd
- False-> return True
+ True -> do mt <- liftIO $ getModificationTime fp
+ return $ (True, mt > fd)
+ False-> return (False, True)
snd' :: (a, b, c) -> b
snd' (a,b,c) = b
@@ -187,13 +205,20 @@ getDir ct = case ct of
CTLayout -> layoutDir
CTController -> controllerDir
CTView -> viewDir
+ CTComponentController -> componentControllerDir
+ CTComponentView -> componentViewDir
getStub :: CodeType -> FilePath
getStub ct = case ct of
CTLayout -> layoutStub
CTController -> controllerStub
CTView -> viewStub
+ CTComponentController -> controllerStub
+ CTComponentView -> viewStub
+getDate (CodeLoadMissing) = error "getDate called with CodeLoadMissing"
getDate (CodeLoadFailure e) = error "getDate called with CodeLoadFailure"
getDate (CodeLoadView _ _ d) = d
getDate (CodeLoadController _ _ d) = d
+getDate (CodeLoadComponentView _ _ d) = d
+getDate (CodeLoadComponentController _ _ d) = d
View
8 Turbinado/Environment/Database.hs
@@ -18,10 +18,10 @@ import Turbinado.Controller.Monad
import Turbinado.Environment.Types
-addDatabaseToEnvironment :: Controller ()
-addDatabaseToEnvironment = do e <- get
+addDatabaseToEnvironment :: (HasEnvironment m) => m ()
+addDatabaseToEnvironment = do e <- getEnvironment
case databaseConnection of
Nothing -> return ()
- Just conn -> do c <- doIO $ conn
- put $ e {getDatabase = Just c}
+ Just conn -> do c <- liftIO $ conn
+ setEnvironment $ e {getDatabase = Just c}
View
4 Turbinado/Environment/Header.hs
@@ -11,8 +11,8 @@ import Turbinado.Controller.Monad
import Turbinado.Environment.Types
import Turbinado.Environment.Request
-getHeader :: HeaderName -> Controller (Maybe String)
-getHeader h = do e <- get
+getHeader :: (HasEnvironment m) => HeaderName -> m (Maybe String)
+getHeader h = do e <- getEnvironment
return $ findHeader h (fromJust $ getRequest e)
View
37 Turbinado/Environment/Logger.hs
@@ -11,33 +11,40 @@ import Data.Dynamic
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}
+addLoggerToEnvironment :: (HasEnvironment m) => m ()
+addLoggerToEnvironment = do e <- getEnvironment
+ f <- liftIO $ S.fileHandler "log" logLevel
+ liftIO $ L.updateGlobalLogger "Turbinado" ( L.setLevel logLevel . L.setHandlers [f])
+ mv <- liftIO $ newMVar ()
+ setEnvironment $ e {getLoggerLock = Just mv}
-takeLoggerLock :: Controller ()
-takeLoggerLock = do e <- get
- doIO $ takeMVar (fromJust $ getLoggerLock e)
+takeLoggerLock :: (HasEnvironment m) => m ()
+takeLoggerLock = do e <- getEnvironment
+ liftIO $ takeMVar (fromJust $ getLoggerLock e)
-putLoggerLock :: Controller ()
-putLoggerLock = do e <- get
- doIO $ putMVar (fromJust $ getLoggerLock e) ()
+putLoggerLock :: (HasEnvironment m) => m ()
+putLoggerLock = do e <- getEnvironment
+ liftIO $ putMVar (fromJust $ getLoggerLock e) ()
-wrapLoggerLock :: (String -> IO ()) -> String -> Controller ()
+wrapLoggerLock :: (HasEnvironment m) => (String -> IO ()) -> String -> m ()
wrapLoggerLock lf s = do takeLoggerLock
- doIO $ lf s
+ liftIO $ lf s
putLoggerLock
+debugM :: (HasEnvironment m) => String -> m ()
debugM = wrapLoggerLock (L.logM "Turbinado" L.DEBUG)
+infoM :: (HasEnvironment m) => String -> m ()
infoM = wrapLoggerLock (L.logM "Turbinado" L.INFO)
+noticeM :: (HasEnvironment m) => String -> m ()
noticeM = wrapLoggerLock (L.logM "Turbinado" L.NOTICE)
+warningM :: (HasEnvironment m) => String -> m ()
warningM = wrapLoggerLock (L.logM "Turbinado" L.WARNING)
+errorM :: (HasEnvironment m) => String -> m ()
errorM = wrapLoggerLock (L.logM "Turbinado" L.ERROR)
+criticalM :: (HasEnvironment m) => String -> m ()
criticalM = wrapLoggerLock (L.logM "Turbinado" L.CRITICAL)
+alertM :: (HasEnvironment m) => String -> m ()
alertM = wrapLoggerLock (L.logM "Turbinado" L.ALERT)
+emergencyM :: (HasEnvironment m) => String -> m ()
emergencyM = wrapLoggerLock (L.logM "Turbinado" L.EMERGENCY)
View
8 Turbinado/Environment/MimeTypes.hs
@@ -47,11 +47,11 @@ import Control.Monad.Trans
import Turbinado.Environment.Types
-setMimeTypes :: MonadState Environment (mt Environment IO) => MimeTypes -> mt Environment IO ()
-setMimeTypes mi = do e <- get
- put $ e {getMimeTypes = Just mi}
+setMimeTypes :: (HasEnvironment m) => MimeTypes -> m ()
+setMimeTypes mi = do e <- getEnvironment
+ setEnvironment $ e {getMimeTypes = Just mi}
-addMimeTypesToEnvironment :: (MonadState Environment (mt Environment IO), MonadIO (mt Environment IO)) => FilePath -> mt Environment IO ()
+addMimeTypesToEnvironment :: (HasEnvironment m) => FilePath -> m ()
addMimeTypesToEnvironment mime_types_file =
do stuff <- liftIO $ readFile mime_types_file
setMimeTypes (MimeTypes $ Map.fromList (parseMimeTypes stuff))
View
13 Turbinado/Environment/Params.hs
@@ -8,28 +8,27 @@ import Network.HTTP
import Network.HTTP.Headers
import Network.URI
-import Turbinado.Controller.Monad
import Turbinado.Environment.Header
import Turbinado.Environment.Request
import Turbinado.Environment.Types
-getParam_u :: String -> Controller String
+getParam_u :: (HasEnvironment m) => String -> m String
getParam_u p = do r <- getParam p
return $ fromJust r
-getParam :: String -> Controller (Maybe String)
+getParam :: (HasEnvironment m) => String -> m (Maybe String)
getParam p = do r <- getParamFromQueryString p
case r of
Just r' -> return r
Nothing -> getParamFromBody p
-getParamFromQueryString :: String -> Controller (Maybe String)
-getParamFromQueryString s = do e <- get
+getParamFromQueryString :: (HasEnvironment m) => String -> m (Maybe String)
+getParamFromQueryString s = do e <- getEnvironment
let qs = uriQuery $ rqURI (fromJust $ getRequest e)
return $ lookup s $ formDecode qs
-getParamFromBody :: String -> Controller (Maybe String)
-getParamFromBody s = do e <- get
+getParamFromBody :: (HasEnvironment m) => String -> m (Maybe String)
+getParamFromBody s = do e <- getEnvironment
ct <- getHeader HdrContentType
let rm = rqMethod (fromJust $ getRequest e)
rb = rqBody (fromJust $ getRequest e)
View
7 Turbinado/Environment/Request.hs
@@ -11,10 +11,9 @@ import Control.Monad
import Control.Monad.State
import Data.Maybe
import Turbinado.Environment.Types
-import Turbinado.Controller.Monad
-addRequestToEnvironment :: HTTP.Request -> Controller ()
-addRequestToEnvironment req = do e <- get
- put $ e {getRequest = Just $ req}
+addRequestToEnvironment :: (HasEnvironment m) => HTTP.Request -> m ()
+addRequestToEnvironment req = do e <- getEnvironment
+ setEnvironment $ e {getRequest = Just $ req}
View
6 Turbinado/Environment/Response.hs
@@ -16,9 +16,9 @@ import System.Time
import System.Locale
-setResponse :: MonadState Environment (mt Environment IO) => HTTP.Response -> mt Environment IO ()
-setResponse resp = do e <- get
- put $ e {getResponse = Just resp}
+setResponse :: (HasEnvironment m) => HTTP.Response -> m ()
+setResponse resp = do e <- getEnvironment
+ setEnvironment $ e {getResponse = Just resp}
isResponseComplete :: Environment -> Bool
isResponseComplete e = case (getResponse e) of
View
17 Turbinado/Environment/Routes.hs
@@ -12,7 +12,6 @@ import Control.Monad
import qualified Network.HTTP as HTTP
import qualified Network.URI as URI
import Turbinado.Controller.Exception
-import Turbinado.Controller.Monad
import Turbinado.Environment.Types
import Turbinado.Environment.Logger
import Turbinado.Environment.Request
@@ -21,18 +20,18 @@ import qualified Turbinado.Environment.Settings as S
import qualified Config.Routes
-addRoutesToEnvironment :: Controller ()
-addRoutesToEnvironment = do e <- get
- put $ e {getRoutes = Just $ Routes $ parseRoutes Config.Routes.routes}
+addRoutesToEnvironment :: (HasEnvironment m) => m ()
+addRoutesToEnvironment = do e <- getEnvironment
+ setEnvironment $ e {getRoutes = Just $ Routes $ parseRoutes Config.Routes.routes}
------------------------------------------------------------------------------
-- Given an Environment
------------------------------------------------------------------------------
-runRoutes :: Controller ()
+runRoutes :: (HasEnvironment m) => m ()
runRoutes = do debugM $ " Routes.runRoutes : starting"
- e <- get
+ e <- getEnvironment
let Routes rs = fromJust $ getRoutes e
r = fromJust $ getRequest e
p = URI.uriPath $ HTTP.rqURI r
@@ -42,10 +41,10 @@ runRoutes = do debugM $ " Routes.runRoutes : starting"
_ -> do mapM (\(k, v) -> setSetting k v) sets
addDefaultAction
-addDefaultAction :: Controller ()
-addDefaultAction = do e <- get
+addDefaultAction :: (HasEnvironment m) => m ()
+addDefaultAction = do e <- getEnvironment
let s = fromJust $ getSettings e
- put $ e {getSettings = Just (M.insertWith (\ a b -> b) "action" (toDyn "Index") s)}
+ setEnvironment $ e {getSettings = Just (M.insertWith (\ a b -> b) "action" (toDyn "Index") s)}
------------------------------------------------------------------------------
-- Generate the Routes from [String]
View
30 Turbinado/Environment/Settings.hs
@@ -19,44 +19,44 @@ import System.FilePath
import Turbinado.Environment.Types
import Turbinado.Controller.Monad
-addSettingsToEnvironment :: Controller ()
-addSettingsToEnvironment = do e <- get
- put $ e {getSettings = Just $ M.fromList defaultSettings }
+addSettingsToEnvironment :: (HasEnvironment m) => m ()
+addSettingsToEnvironment = do e <- getEnvironment
+ setEnvironment $ e {getSettings = Just $ M.fromList defaultSettings }
------------------------------------------------------------------
-- Set/Get an individual settting
------------------------------------------------------------------
-getSetting :: Typeable a => String -> Controller (Maybe a)
-getSetting s = do e <- get
+getSetting :: (HasEnvironment m, Typeable a) => String -> m (Maybe a)
+getSetting s = do e <- getEnvironment
return $ maybe Nothing (fromDynamic) ( M.lookup s (fromJust $ getSettings e) )
getSetting_u s = getSetting s >>= \v -> return (fromJust v)
-setSetting :: (Typeable a) => String -> a -> Controller ()
-setSetting k v = do e <- get
- put $ e { getSettings = Just (M.insert k (toDyn v) (fromJust $ getSettings e))}
+setSetting :: (HasEnvironment m, Typeable a) => String -> a -> m ()
+setSetting k v = do e <- getEnvironment
+ setEnvironment $ e { getSettings = Just (M.insert k (toDyn v) (fromJust $ getSettings e))}
defaultSettings = [ ("layout", toDyn "Default") ]
------------------------------------------------------------------
-- Shorthands
------------------------------------------------------------------
-getController :: Controller (FilePath, String)
-getController = do e <- get
+getController :: (HasEnvironment m) => m (FilePath, String)
+getController = do e <- getEnvironment
c <- getSetting "controller"
a <- getSetting "action"
return $ (fromJust c,
actionName $ fromJust a)
where actionName s = (toLower $ head s) : (tail s)
-clearLayout :: Controller ()
+clearLayout :: (HasEnvironment m) => m ()
clearLayout = setSetting "layout" ""
-getLayout :: Controller (FilePath, String)
-getLayout = (\l -> return (fromJust l, "page")) =<< getSetting "layout"
+getLayout :: (HasEnvironment m) => m (FilePath, String)
+getLayout = (\l -> return (fromJust l, "markup")) =<< getSetting "layout"
-getView :: Controller (FilePath, String)
+getView :: (HasEnvironment m) => m (FilePath, String)
getView = do c <- getSetting_u "controller"
a <- getSetting_u "action"
- return (joinPath $ map normalise [c,a], "page")
+ return (joinPath $ map normalise [c,a], "markup")
View
13 Turbinado/Environment/Types.hs
@@ -16,6 +16,10 @@ import Config.Master
import System.Time
import System.Plugins
+class (MonadIO m) => HasEnvironment m where
+ getEnvironment :: m Environment
+ setEnvironment :: Environment -> m ()
+
-- Stuffing all Environment "types" into this file to avoid
-- recursive imports...
@@ -50,16 +54,19 @@ newEnvironment = Environment { getCodeStore = Nothing
-- * Types for CodeStore
--
-data CodeType = CTView | CTController | CTLayout
+data CodeType = CTView | CTController | CTComponentView | CTComponentController | CTLayout deriving (Show)
type CodeDate = ClockTime
type Function = String
type CodeLocation = (FilePath, Function)
data CodeStore = CodeStore (MVar CodeMap)
type CodeMap = M.Map CodeLocation CodeStatus
-data CodeStatus = CodeLoadFailure String |
+data CodeStatus = CodeLoadMissing |
+ CodeLoadFailure String |
CodeLoadController (StateT Environment IO ()) Module CodeDate |
- CodeLoadView (XMLGenT (StateT Environment IO) XML ) Module CodeDate
+ CodeLoadView (XMLGenT (StateT Environment IO) XML ) Module CodeDate |
+ CodeLoadComponentController (StateT Environment IO ()) Module CodeDate |
+ CodeLoadComponentView (XMLGenT (StateT Environment IO) XML ) Module CodeDate
--
-- * Types for Database
View
20 Turbinado/Environment/ViewData.hs
@@ -14,25 +14,23 @@ import Data.Dynamic
import Turbinado.Environment.Logger
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)}
+addViewDataToEnvironment :: (HasEnvironment m) => m ()
+addViewDataToEnvironment = do e <- getEnvironment
+ setEnvironment $ e {getViewData = Just (M.empty :: ViewData)}
-getViewDataValue :: (Typeable a) => String -> View (Maybe a)
-getViewDataValue k = do e <- lift get
+getViewDataValue :: (HasEnvironment m, Typeable a) => String -> m (Maybe a)
+getViewDataValue k = do e <- getEnvironment
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 :: (HasEnvironment m, Typeable a) => String -> m a
getViewDataValue_u k = do v <- getViewDataValue k
return $ fromJust v
-setViewDataValue :: (Typeable a) => String -> a -> Controller ()
-setViewDataValue k v = do e <- get
+setViewDataValue :: (HasEnvironment m, Typeable a) => String -> a -> m ()
+setViewDataValue k v = do e <- getEnvironment
let vd = fromJust $ getViewData e
vd' = M.insert k (toDyn v) vd
- put $ e {getViewData = Just vd'}
+ setEnvironment $ e {getViewData = Just vd'}
View
6 Turbinado/Layout.hs
@@ -15,9 +15,9 @@ import Turbinado.Environment.Settings
import Turbinado.View
insertView :: View XML
-insertView = do cl <- lift getView
- lift $ debugM $ " Layout: insertView : loading " ++ (fst cl) ++ " - " ++ (snd cl)
- c <- lift $ retrieveCode CTView cl
+insertView = do cl <- getView
+ debugM $ " Layout: insertView : loading " ++ (fst cl) ++ " - " ++ (snd cl)
+ c <- retrieveCode CTView cl
case c of
CodeLoadView v _ _ -> v
CodeLoadController _ _ _ -> error "retrieveAndRunLayout called, but returned CodeLoadController"
View
11 Turbinado/Server.hs
@@ -66,9 +66,13 @@ main =
startServer :: PortNumber -> IO ()
startServer pnr
= withSocketsDo $
- do e <- runController (sequence_ [ addLoggerToEnvironment
+ do e <- runController
+ (sequence_ $ [ addLoggerToEnvironment
, addCodeStoreToEnvironment
- , addMimeTypesToEnvironment "Config/mime.types"]) newEnvironment
+ , addMimeTypesToEnvironment "Config/mime.types"]
+ ++ customSetupFilters
+ )
+ newEnvironment
sock <- listenOn $ PortNumber pnr
workerPoolMVar <- newMVar $ WorkerPool 0 [] []
mainLoop sock workerPoolMVar e
@@ -108,7 +112,7 @@ handleRequest sock e
, addRoutesToEnvironment ]) e
case (isResponseComplete e') of
True -> sendResponse sock e'
- False -> do e'' <- requestHandler e'
+ False -> do e'' <- runController requestHandler e'
sendResponse sock e''
)
`catchTurbinado` (\ex -> handleTurbinado sock ex e)
@@ -127,6 +131,7 @@ data WorkerPool = WorkerPool { numWorkers :: Int,
idleWorkers :: [WorkerThread],
busyWorkers :: [(WorkerThread, ExpiresTime)]}
+-- TODO: add a Maximum # of threads
--getWorkerThread :: MVar WorkerPool -> IO WorkerThread
getWorkerThread mv e =
do wp <- takeMVar mv
View
16 Turbinado/Server/Handlers/RequestHandler.hs
@@ -46,11 +46,8 @@ preFilters = [Routes.runRoutes ]
postFilters :: [Controller ()]
postFilters = []
-requestHandler :: Environment -> IO Environment
-requestHandler e = runController requestHandler' e
-
-requestHandler' :: Controller ()
-requestHandler' = do
+requestHandler :: Controller ()
+requestHandler = do
debugM $ " requestHandler : running pre and main filters"
-- Run the Pre filters, the page
sequence_ $ preFilters ++
@@ -65,15 +62,13 @@ requestHandler' = do
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' _ _ -> p'
- CodeLoadView _ _ _ -> error "retrieveAndRunView called, but returned CodeLoadView"
CodeLoadFailure e -> errorResponse e
+ CodeLoadView _ _ _ -> error "retrieveAndRunController: retrieveCode called, but returned CodeLoadView"
+ CodeLoadMissing -> error "retrieveAndRunController: retrieveCode called, but returned CodeLoadMissing"
retrieveAndRunLayout :: Controller ()
retrieveAndRunLayout =
@@ -87,7 +82,8 @@ retrieveAndRunLayout =
_ -> retrieveCode CTLayout l
case p of
CodeLoadView p' _ _ -> evalView p'
- CodeLoadController _ _ _ -> error "retrieveAndRunLayout called, but returned CodeLoadController"
CodeLoadFailure e -> errorResponse e
+ CodeLoadController _ _ _ -> error "retrieveAndRunView: retrieveCode called, but returned CodeLoadController"
+ CodeLoadMissing -> error "retrieveAndRunView: retrieveCode called, but returned CodeLoadMissing"
View
2  Turbinado/Server/Network.hs
@@ -18,7 +18,7 @@ import Network.HTTP
receiveRequest :: Socket -> Controller ()
receiveRequest sock = do
- req <- doIO $ receiveHTTP sock
+ req <- liftIO $ receiveHTTP sock
case req of
Left _ -> throwTurbinado $ BadRequest "Looks as though we've got a bad request, sir"
Right r -> do e <- get
View
24 Turbinado/Server/StandardResponse.hs
@@ -26,45 +26,45 @@ import Turbinado.Controller.Monad
instance Eq Header where
(==) (Header hn1 _) (Header hn2 _) = hn1 == hn2
-fileNotFoundResponse :: FilePath -> Controller ()
+fileNotFoundResponse :: (HasEnvironment m) => FilePath -> m ()
fileNotFoundResponse fp =
- do t <- doIO $ getClockTime
+ do t <- liftIO $ getClockTime
setResponse (Response (4,0,0)
"File Not Found"
(buildHeaders (Just $ length body) t [])
(body))
where body = "<html><body>\n <p><big>404 File Not Found</big></p>\n <p>Requested resource: "++ fp ++ "</p>\n </body></html>"
-cachedContentResponse :: Int -> String -> String -> Controller ()
+cachedContentResponse :: (HasEnvironment m) => Int -> String -> String -> m ()
cachedContentResponse age ct body =
- do t <- doIO $ getClockTime
+ do t <- liftIO $ getClockTime
pageResponse (buildHeaders
Nothing t
[Header HdrCacheControl $ "max-age=" ++ (show age) ++ ", public"
, Header HdrContentType ct])
body
-pageResponse :: [Header] -> String -> Controller ()
+pageResponse :: (HasEnvironment m) => [Header] -> String -> m ()
pageResponse hds body =
- do t <- doIO $ getClockTime
+ do t <- liftIO $ getClockTime
setResponse (Response stSuccess "OK"
(buildHeaders (Just $ length body) t hds) (body))
-redirectResponse :: String -> Controller ()
+redirectResponse :: (HasEnvironment m) => String -> m ()
redirectResponse l =
- do t <- doIO $ getClockTime
+ do t <- liftIO $ getClockTime
setResponse (Response (3,0,2) "OK" (buildHeaders Nothing t [Header HdrLocation l]) "")
-errorResponse :: String -> Controller ()
+errorResponse :: (HasEnvironment m) => String -> m ()
errorResponse err =
- do t <- doIO $ getClockTime
+ do t <- liftIO $ getClockTime
setResponse (Response stError "Internal Server Error"
(buildHeaders (Just $ length body) t []) (body))
where body = "<html><body>\n <p><big>500 Internal Server Error</big></p>\n <p>Error specification:<br/>\n" ++ err ++ "</p>\n </body></html>"
-badReqResponse :: Controller ()
+badReqResponse :: (HasEnvironment m) => m ()
badReqResponse =
- do t <- doIO $ getClockTime
+ do t <- liftIO $ getClockTime
setResponse (Response stBadReq "Bad Request"
(buildHeaders (Just $ length body) t []) body)
where body = "<html><body>\n <p><big>400 Bad Request</big></p>\n </body></html>"
View
6 Turbinado/Server/StaticContent.hs
@@ -25,7 +25,7 @@ import Config.Master
tryStaticContent :: Controller ()
tryStaticContent =
do e <- get
- cDir <- doIO $ getCurrentDirectory
+ cDir <- liftIO $ getCurrentDirectory
let mt = fromJust $ getMimeTypes e
rq = fromJust $ getRequest e
f = drop 1 $ uriPath $ rqURI rq
@@ -36,9 +36,9 @@ tryStaticContent =
sequence_ $ map (tryToGetStaticContent mt) trydirs
tryToGetStaticContent :: MimeTypes -> FilePath -> Controller ()
-tryToGetStaticContent mt p = do exist <- doIO $ doesFileExist p
+tryToGetStaticContent mt p = do exist <- liftIO $ doesFileExist p
case exist of
False -> return ()
- True -> do f <- doIO $ readFile p
+ True -> do f <- liftIO $ readFile p
let ct = maybe "text/html" (show) (mimeTypeOf mt p)
cachedContentResponse 600 ct f
View
6 Turbinado/Stubs/ComponentController.hs
@@ -0,0 +1,6 @@
+import Config.Master
+import Turbinado.Controller
+
+-- SPLIT HERE
+
+
View
8 Turbinado/Stubs/ComponentView.hs
@@ -0,0 +1,8 @@
+import Config.Master
+import Turbinado.View
+import Turbinado.View.Helpers
+import Control.Monad.Trans
+
+-- SPLIT HERE
+markup :: View XML
+
View
3  Turbinado/Stubs/Layout.hs
@@ -4,5 +4,4 @@ import Turbinado.View
import Turbinado.View.Helpers
-- SPLIT HERE
-page :: View XML
-
+markup :: View XML
View
2  Turbinado/Stubs/View.hs
@@ -3,6 +3,6 @@ import Turbinado.View
import Turbinado.View.Helpers
import Control.Monad.Trans
-page :: View XML
+markup :: View XML
-- SPLIT HERE
View
91 Turbinado/View.hs
@@ -3,13 +3,12 @@ module Turbinado.View (
setEnvironment,
evalView,
defaultContentType,
- modifyEnvironment,
-- limited export from Turbinado.View.Monad
View, ViewT, ViewT',
runView, runViewT,
- get, put,
-- * Functions
- doIO, catch,
+ liftIO, catch,
+ insertComponent,
-- Module Exports
module Turbinado.View.HTML,
@@ -29,6 +28,7 @@ import Control.Exception (catchDyn)
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans (MonadIO(..))
+import Data.Char
import Data.List
import Data.Maybe
import qualified Network.HTTP as HTTP
@@ -38,6 +38,7 @@ import System.FilePath
import Turbinado.Controller.Monad hiding (catch)
import Turbinado.Environment.CodeStore
+import Turbinado.Environment.Logger
import Turbinado.Environment.Params
import Turbinado.Environment.Request
import Turbinado.Environment.Response
@@ -47,64 +48,48 @@ import Turbinado.Environment.ViewData
import Turbinado.Server.StandardResponse
import Turbinado.View.Exception
import Turbinado.View.HTML
-import Turbinado.View.Monad hiding (doIO)
+import Turbinado.View.Monad hiding (liftIO)
import Turbinado.View.XML hiding (Name)
import Turbinado.View.XML.PCDATA
import Turbinado.View.XMLGenerator
import Turbinado.Utility.General
-
-evalView :: View XML -> Controller ()
-evalView p = do e <- get
- (x, e') <- doIO $ runView p e
+evalView :: (HasEnvironment m) => View XML -> m ()
+evalView p = do e <- getEnvironment
+ (x, e') <- liftIO $ runView p e
pageResponse [] $ renderAsHTML x
defaultContentType :: String
defaultContentType = "text/html; charset=ISO-8859-1"
---
--- * Environment functions
---
-
-getEnvironment :: View Environment
-getEnvironment = lift get
-
-setEnvironment :: Environment -> View ()
-setEnvironment e = lift $ put e
-
-modifyEnvironment :: (Environment -> Environment) -> View ()
-modifyEnvironment = lift . modify
-
---
--- * Header functions
---
-
---
--- * Cookie functions
---
-
-{-
--- | Get the value of a cookie.
-getCookie :: String -- ^ The name of the cookie.
- -> View (Maybe String) -- ^ 'Nothing' if the cookie does not exist.
-getCookie name = getRequest >>= \r -> return $ Cookie.findCookie name
- (fromMaybe "" $ HTTP.lookupHeader HTTP.HdrCookie (HTTP.rqHeaders $ httpRequest r))
-
--- | Same as 'getCookie', but tries to read the value to the desired type.
-readCookie :: (Read a) =>
- String -- ^ The name of the cookie.
- -> View (Maybe a) -- ^ 'Nothing' if the cookie does not exist
- -- or if the value could not be interpreted
- -- at the desired type.
-readCookie = liftM (>>= maybeRead) . getCookie
-
--- | Set a cookie.
-setCookie :: Cookie.Cookie -> View HTTP.Response
-setCookie c = getResponse >>= return . HTTP.replaceHeader HTTP.HdrSetCookie (Cookie.showCookie c)
-
--- | Delete a cookie from the client
-deleteCookie :: Cookie.Cookie -> View HTTP.Response
-deleteCookie = setCookie . Cookie.deleteCookie
--}
-
+insertComponent :: String -> String -> [(String, String)] -> View XML
+insertComponent controller action opts =
+ do debugM $ " insertComponent: Starting"
+ p <- retrieveCode CTComponentController (controller, (toLower $ head action) : (tail action))
+ case p of
+ CodeLoadMissing -> return $ cdata $ "insertComponent error: code missing : " ++ controller ++ " - " ++ action
+ CodeLoadFailure e -> return $ cdata $ "insertComponent error: " ++ e
+ CodeLoadComponentController p' _ _ -> do oldE <- getEnvironment
+ mapM_ (\(k, v) -> setSetting k v) opts
+ lift $ p'
+ -- allow for overloading of the Component Controller and View
+ c <- getSetting "component-controller"
+ a <- getSetting "component-view"
+ insertComponentView oldE (fromMaybe controller c) (fromMaybe action a)
+ _ -> return $ cdata $ "insertComponent error: received incorrect CodeStatus"
+
+insertComponentView :: Environment -> String -> String -> View XML
+insertComponentView oldE controller action =
+ do debugM $ " insertComponentView: Starting"
+ v <- retrieveCode CTComponentView (joinPath [controller, action], "markup")
+ case v of
+ CodeLoadMissing -> do setEnvironment oldE
+ return $ cdata $ "insertComponentView error: code missing : " ++ (joinPath [controller, action]) ++ " - markup"
+ CodeLoadFailure e -> do setEnvironment oldE
+ return $ cdata $ "insertComponentView error: " ++ e
+ CodeLoadComponentView v' _ _ -> do res <- v'
+ setEnvironment oldE
+ return res
+ _ -> do setEnvironment oldE
+ return $ cdata $ "insertComponentView error"
View
20 Turbinado/View/Monad.hs
@@ -5,13 +5,13 @@ module Turbinado.View.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 HSX.XMLGenerator (XMLGenT(..), unXMLGenT)
import qualified Network.HTTP as HTTP
@@ -33,6 +33,18 @@ type View = ViewT IO
type ViewT' m = StateT Environment m
type ViewT m = XMLGenT (ViewT' m)
+instance HasEnvironment View where
+ getEnvironment = lift get
+ setEnvironment = lift . put
+
+
+getEnvironment :: View Environment
+getEnvironment = lift get
+
+setEnvironment :: Environment -> View ()
+setEnvironment e = lift $ put e
+
+
-- do NOT export this in the final version
dummyEnv = undefined
@@ -44,10 +56,6 @@ runView p e = runStateT (unXMLGenT p) e
runViewT :: ViewT IO a -> Environment -> IO (a, Environment)
runViewT = runStateT . unXMLGenT
--- | Execute an IO computation within the View monad.
-doIO :: IO a -> View a
-doIO = liftIO
-
-----------------------------------------------------------------------
-- Exception handling
Please sign in to comment.
Something went wrong with that request. Please try again.