Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Syncing with turbinado-website

  • Loading branch information...
commit 194a9f838e1e6248921fba003e7e2f9403228054 1 parent e41454b
Alson Kemp authored
7 Config/Master.hs
View
@@ -11,8 +11,8 @@ import Config.App
compileArgs =
[ "-fglasgow-exts"
- , "-fallow-overlapping-instances"
- , "-fallow-undecidable-instances"
+ , "-XOverlappingInstances"
+ , "-XUndecidableInstances"
, "-F", "-pgmFtrhsx"
, "-fno-warn-overlapping-patterns"
, "-odir " ++ compiledDir
@@ -28,6 +28,7 @@ mUserPkgConf = [""]
layoutDir = "App/Layouts"
layoutStub = "Turbinado/Stubs/Layout.hs"
+configDir = "Config"
modelDir = "App/Models"
viewDir = "App/Views"
viewStub = "Turbinado/Stubs/View.hs"
@@ -38,8 +39,6 @@ componentViewStub = "Turbinado/Stubs/ComponentView.hs"
componentControllerDir = "App/Components/Controllers"
componentControllerStub = "Turbinado/Stubs/ComponentController.hs"
-configDir = "Config"
-
staticDirs = ["static", "tmp/cache"]
compiledDir = "tmp/compiled"
2  Turbinado/Controller.hs
View
@@ -15,6 +15,7 @@ module Turbinado.Controller (
module Data.Maybe,
+ module Config.Master,
module Turbinado.Environment.CodeStore,
module Turbinado.Environment.Header,
module Turbinado.Environment.Logger,
@@ -35,6 +36,7 @@ import qualified Network.HTTP as HTTP
import Prelude hiding (catch)
import qualified Database.HDBC as HDBC
+import Config.Master
import Turbinado.Environment.CodeStore
import Turbinado.Environment.Database
import Turbinado.Environment.Header
6 Turbinado/Database/ORM/Generator.hs
View
@@ -1,4 +1,6 @@
-module Turbinado.Database.ORM.Generator where
+module Turbinado.Database.ORM.Generator (
+ generateModels
+) where
import Control.Monad
import Data.List
@@ -11,6 +13,8 @@ import Turbinado.Database.ORM.Types
import Turbinado.Database.ORM.Output
import Turbinado.Database.ORM.PostgreSQL
+-- | Outputs ORM models to App/Models. User configurable files
+-- are in App/Models. Machine generated files are in App/Models/Bases.
generateModels :: IO ()
generateModels = do conn <- fromJust databaseConnection
ts <- getTables conn
110 Turbinado/Database/ORM/Output.hs
View
@@ -19,7 +19,7 @@ type TypeName = String
writeModels ts =
do writeFile "App/Models/Bases/Common.hs" generateCommon
mapM_ (\(t, (cs, pk)) ->
- let typeName = (capitalizeName t) in
+ let typeName = (toType t) in
do e <- doesFileExist (joinPath ["App/Models", typeName ++ ".hs"])
when (not e) (writeFile (joinPath ["App/Models", typeName++".hs"]) (generateModelFile typeName) )
writeFile (joinPath ["App/Models/Bases", typeName ++ "Type.hs"]) (generateType t typeName pk ts cs)
@@ -95,7 +95,14 @@ generateFunctions t typeName pk ts cs =
generateHasFindByPrimaryKey t cs typeName pk ++
[""] ++
generateIsModel t cs typeName
-
+ ++
+ [""
+ ,"deleteWhere :: (HasEnvironment m) => SelectString -> SelectParams -> m Integer"
+ ,"deleteWhere ss sp = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.run conn (\"DELETE FROM " ++ t++ " WHERE (\" ++ ss ++ \") \") sp"
+ ," return res"
+ ]
generateRelations :: TableName ->
TypeName ->
PrimaryKey ->
@@ -134,13 +141,13 @@ generateRelations t typeName pk ts cs =
generateHasParents t ts
generateChildModelImports cs =
- map (\ctn -> "import qualified App.Models.Bases." ++ capitalizeName ctn ++ "Type as " ++ capitalizeName ctn ++ "Type\nimport qualified App.Models.Bases." ++ capitalizeName ctn ++ "Functions as " ++ capitalizeName ctn ++ "Functions") $
+ map (\ctn -> "import qualified App.Models.Bases." ++ toType ctn ++ "Type as " ++ toType ctn ++ "Type\nimport qualified App.Models.Bases." ++ toType ctn ++ "Functions as " ++ toType ctn ++ "Functions") $
nub $
map fst $ concat $
map (\(_, fks, _) -> fks) $ M.elems cs
generateParentModelImports t ts =
- map (\ptn -> "import qualified App.Models.Bases." ++ capitalizeName ptn ++ "Type as " ++ capitalizeName ptn ++ "Type\nimport qualified App.Models.Bases." ++ capitalizeName ptn ++ "Functions as " ++ capitalizeName ptn ++ "Functions") $
+ map (\ptn -> "import qualified App.Models.Bases." ++ toType ptn ++ "Type as " ++ toType ptn ++ "Type\nimport qualified App.Models.Bases." ++ toType ptn ++ "Functions as " ++ toType ptn ++ "Functions") $
nub $ filter (not . null) $
map parentFilter $ M.assocs ts
where parentFilter (ptn, (cs, _)) =
@@ -204,7 +211,8 @@ generateCommon = unlines $
,"class (DatabaseModel model) =>"
," HasFindByPrimaryKey model primaryKey | model -> primaryKey where"
," find :: (HasEnvironment m) => primaryKey -> m model"
- ," update :: (HasEnvironment m) => model -> m () "
+ ," delete :: (HasEnvironment m) => primaryKey -> m ()"
+ ," update :: (HasEnvironment m) => model -> m ()"
,""
]
@@ -218,11 +226,18 @@ generateIsModel t cs typeName =
," insert m returnId = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.run conn (\" INSERT INTO " ++ t ++ " (" ++ (intercalate "," $ M.keys cs) ++") VALUES (" ++ (intercalate "," $ map generateQs (M.assocs cs) ) ++ ")\") ( " ++ (intercalate " ++ " $ filter (not . null) $ map generateArgs (M.assocs cs) ) ++ ")"
- ," liftIO $ HDBC.handleSqlError $ HDBC.commit conn"
- ," if returnId"
- ," then do 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"
- ," else return Nothing"
+ ," case res of"
+ ," 0 -> (liftIO $ HDBC.handleSqlError $ HDBC.rollback conn) >>"
+ ," (throwDyn $ HDBC.SqlError"
+ ," {HDBC.seState = \"\","
+ ," HDBC.seNativeError = (-1),"
+ ," HDBC.seErrorMsg = \"Rolling back. No record inserted :" ++ t ++ " : \" ++ (show m)"
+ ," })"
+ ," 1 -> liftIO $ HDBC.handleSqlError $ HDBC.commit conn >>"
+ ," if returnId"
+ ," then do i <- liftIO $ HDBC.catchSql (HDBC.handleSqlError $ HDBC.quickQuery' conn \"SELECT lastval()\" []) (\\_ -> HDBC.commit conn >> (return $ [[HDBC.toSql (0 :: Integer)]]) ) "
+ ," return $ HDBC.fromSql $ head $ head i"
+ ," else return Nothing"
," findAll = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn \"SELECT " ++ cols cs ++ " FROM " ++ t ++ "\" []"
@@ -233,11 +248,11 @@ generateIsModel t cs typeName =
," 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]"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " ORDER BY \" ++ op) []"
," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
," 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])"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") ORDER BY \" ++ op) sp"
," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
," findOneWhere ss sp = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
@@ -245,19 +260,19 @@ generateIsModel t cs typeName =
," 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]"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " ORDER BY \" ++ op ++ \" LIMIT 1\") []"
," 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])"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") ORDER BY \" ++ op ++\" LIMIT 1\") sp"
," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
]
where generateQs :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) -> String
- generateQs (c, (desc, _, False)) = if ((colNullable desc) == Just True) then ("\" ++ (case (" ++ partiallyCapitalizeName c ++ " m) of Nothing -> \"DEFAULT\"; Just x -> \"?\") ++ \"") else "?"
- generateQs (c, (_, _, True)) = "\" ++ (case (" ++ partiallyCapitalizeName c ++ " m) of Nothing -> \"DEFAULT\"; Just x -> \"?\") ++ \""
+ generateQs (c, (desc, _, False)) = if ((colNullable desc) == Just True) then ("\" ++ (case (" ++ toFunction c ++ " m) of Nothing -> \"DEFAULT\"; Just x -> \"?\") ++ \"") else "?"
+ generateQs (c, (_, _, True)) = "\" ++ (case (" ++ toFunction c ++ " m) of Nothing -> \"DEFAULT\"; Just x -> \"?\") ++ \""
generateArgs :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) -> String
- generateArgs (c, (desc, _, False)) = if ((colNullable desc) == Just True) then ("(case (" ++ partiallyCapitalizeName c ++ " m) of Nothing -> []; Just x -> [HDBC.toSql x])") else ("[HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m]")
- generateArgs (c, (_, _, True)) = "(case (" ++ partiallyCapitalizeName c ++ " m) of Nothing -> []; Just x -> [HDBC.toSql x])"
+ generateArgs (c, (desc, _, False)) = if ((colNullable desc) == Just True) then ("(case (" ++ toFunction c ++ " m) of Nothing -> []; Just x -> [HDBC.toSql x])") else ("[HDBC.toSql $ " ++ toFunction c ++ " m]")
+ generateArgs (c, (_, _, True)) = "(case (" ++ toFunction c ++ " m) of Nothing -> []; Just x -> [HDBC.toSql x])"
generateHasFindByPrimaryKey :: TableName -> Columns -> TypeName -> PrimaryKey -> [String]
generateHasFindByPrimaryKey t cs typeName pk =
@@ -280,10 +295,28 @@ generateHasFindByPrimaryKey t cs typeName pk =
," HDBC.seErrorMsg = \"Too many records found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
," }"
,""
+ ," delete pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length pk)]) ++ ") = do"
+ ," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
+ ," res <- liftIO $ HDBC.handleSqlError $ HDBC.run conn (\"DELETE FROM " ++ t ++ " WHERE (" ++ (generatePrimaryKeyWhere pk) ++ ")\") [" ++ (unwords $ intersperse "," $ map (\(c,i) -> "HDBC.toSql pk" ++ (show i)) (zip pk [1..])) ++ "]"
+ ," case res of"
+ ," 0 -> (liftIO $ HDBC.handleSqlError $ HDBC.rollback conn) >>"
+ ," (throwDyn $ HDBC.SqlError"
+ ," {HDBC.seState = \"\","
+ ," HDBC.seNativeError = (-1),"
+ ," HDBC.seErrorMsg = \"Rolling back. No record found when deleting by Primary Key:" ++ t ++ " : \" ++ (show pk)"
+ ," })"
+ ," 1 -> (liftIO $ HDBC.handleSqlError $ HDBC.commit conn) >> return ()"
+ ," _ -> (liftIO $ HDBC.handleSqlError $ HDBC.rollback conn) >>"
+ ," (throwDyn $ HDBC.SqlError"
+ ," {HDBC.seState = \"\","
+ ," HDBC.seNativeError = (-1),"
+ ," HDBC.seErrorMsg = \"Rolling back. Too many records deleted when deleting by Primary Key:" ++ t ++ " : \" ++ (show 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 ) ++ "]"
+ ," [" ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ toFunction c ++ " m") (M.keys cs) ) ++ ", " ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ toFunction c ++ " m") pk ) ++ "]"
," liftIO $ HDBC.handleSqlError $ HDBC.commit conn"
," return ()"
]
@@ -297,8 +330,8 @@ generateHasChildren_t t cn (_, fks, _) typeName = unlines $ map (\(fkt, fkc) ->
generateHasChildren_t_k :: TableName -> ColumnName -> TableName -> ColumnName -> TypeName -> String
generateHasChildren_t_k t cn fkt fkc typeName =
unlines $
- ["findAllChild" ++ capitalizeName fkt ++ " :: (HasEnvironment m) => " ++ capitalizeName t ++ " -> m [" ++ capitalizeName fkt ++ "Type." ++ capitalizeName fkt ++ "]"
- ,"findAllChild" ++ capitalizeName fkt ++ " p = findAllWhere \"" ++ fkc ++ " = ?\" [HDBC.toSql $ " ++ partiallyCapitalizeName cn ++ " p]"
+ ["findAllChild" ++ toType fkt ++ " :: (HasEnvironment m) => " ++ toType t ++ " -> m [" ++ toType fkt ++ "Type." ++ toType fkt ++ "]"
+ ,"findAllChild" ++ toType fkt ++ " p = findAllWhere \"" ++ fkc ++ " = ?\" [HDBC.toSql $ " ++ toFunction cn ++ " p]"
]
@@ -314,8 +347,8 @@ generateHasParents ctn ts =
generateHasParent_t :: TableName -> ColumnName -> TableName -> ColumnName -> String
generateHasParent_t ptn pcn ctn ccn =
unlines $
- ["parent" ++ capitalizeName ptn ++ " :: (HasEnvironment m) => " ++ capitalizeName ctn ++ " -> m " ++ capitalizeName ptn ++ "Type." ++ capitalizeName ptn
- ,"parent" ++ capitalizeName ptn ++ " self = findOneWhere \"" ++ pcn ++ " = ?\" [HDBC.toSql $ " ++ partiallyCapitalizeName ccn ++ " self]"
+ ["parent" ++ toType ptn ++ " :: (HasEnvironment m) => " ++ toType ctn ++ " -> m " ++ toType ptn ++ "Type." ++ toType ptn
+ ,"parent" ++ toType ptn ++ " self = findOneWhere \"" ++ pcn ++ " = ?\" [HDBC.toSql $ " ++ toFunction ccn ++ " self]"
]
@@ -340,7 +373,7 @@ cols cs = unwords $ intersperse "," $ M.keys cs
columnToFieldLabel :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) -> String
columnToFieldLabel cd@(name, (desc, _, _)) =
- " " ++ partiallyCapitalizeName name ++ " :: " ++
+ " " ++ toFunction name ++ " :: " ++
maybeColumnLabel cd ++
getHaskellTypeString (colType desc)
@@ -372,26 +405,13 @@ getHaskellTypeString SqlUTCTimeT = "TimeDiff"
getHaskellTypeString _ = error "Don't know how to translate this SqlTypeId to a SqlValue"
---type SelectParameters = String
-
---class TableType a where
--- find :: (IConnection conn) => conn -> Int -> a
--- findBy :: (IConnection conn) => conn -> SelectParameters -> [a]
-
---
--- Converts "column_name" to "ColumnName" (for types)
---
-capitalizeName [] = error "capitalizeName passed an empty string"
-capitalizeName (colname':colname) =
- concat
- (map (\(s:ss) -> (Data.Char.toUpper s) : ss) $
- words $ (Data.Char.toUpper colname') :
- map (\c -> if (c=='_') then ' ' else c) colname)
+-- | Used for safety. Lowercases the first letter to
+-- make a valid function.
+toFunction [] = error "toFunction passed an empty string"
+toFunction (firstLetter:letters) = (Data.Char.toLower firstLetter) : letters
---
--- Converts "column_name" to "columnName" (for functions)
---
-partiallyCapitalizeName colname =
- (\(s:ss) -> (Data.Char.toLower s) : ss) $
- capitalizeName colname
+-- | Used for safety. Uppercases the first letter to
+-- make a valid type.
+toType [] = error "toType passed an empty string"
+toType (firstLetter:letters) = (Data.Char.toUpper firstLetter) : letters
49 Turbinado/Environment/CodeStore.hs
View
@@ -36,13 +36,15 @@ addCodeStoreToEnvironment = do e <- getEnvironment
mv <- liftIO $ newMVar $ empty
setEnvironment $ e {getCodeStore = Just $ CodeStore mv}
+-- | This function attempts to pull a function from a pre-loaded cache or, if
+-- the function doesn't exist or is out-of-date, loads the code from disk.
retrieveCode :: (HasEnvironment m) => CodeType -> CodeLocation -> m CodeStatus
retrieveCode ct cl' = do
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')
+ return (addExtension (joinPath $ map normalise [path, dropExtension $ fst cl']) "hs", snd cl')
debugM $ " CodeStore : retrieveCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
cmap <- liftIO $ takeMVar mv
let c= lookup cl cmap
@@ -72,6 +74,8 @@ retrieveCode ct cl' = do
Just clv@(CodeLoadComponentView _ _ _) -> do debugM (fst cl ++ " : CodeLoadComponentView" )
return clv
+-- | Checks to see if the file exists and if the file is newer than the loaded function. If the
+-- code needs to be reloaded, then 'loadCode' will be called.
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
@@ -84,24 +88,33 @@ checkReloadCode ct cmap cstat cl = do
return cmap
(True, True) -> do debugM $ " CodeStore : checkReloadCode : Need reload"
loadCode ct cmap cl
+ where needReloadCode :: (HasEnvironment m) => FilePath -> CodeDate -> m (Bool, Bool)
+ needReloadCode fp fd = do
+ fe <- liftIO $ doesFileExist fp
+ case fe of
+ True -> do mt <- liftIO $ getModificationTime fp
+ return $ (True, mt > fd)
+ False-> return (False, True)
+--------------------------------------------------------------------------
-- The beast
--- In cases of Merge, Make or Load failures leave the original files in place and log the error
+--------------------------------------------------------------------------
+
+-- | Begins the code load process, which comprises merging the code with
+-- the appropriate Stub (in Turbinado/Stubs) to the tmp/compiled directory,
+-- making the code, and loading it.
loadCode :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> m CodeMap
loadCode ct cmap cl = do
debugM $ "\tCodeStore : loadCode : loading " ++ (fst cl) ++ " - " ++ (snd cl)
- fe <- liftIO $ doesFileExist $ fst cl
- case fe of
- False -> debugM ("\tFile not found: " ++ fst cl) >> return cmap
- True -> mergeCode ct cmap cl
+ mergeCode ct cmap cl
+-- | Merges the application code with the appropriate Stub, places the merged
+-- file into @tmp/compiled@, then calls 'makeCode'.
mergeCode :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> m CodeMap
mergeCode ct cmap cl = do
debugM $ "\tMerging " ++ (fst cl)
- -- d <- getCurrentDirectory
- --debugM $ " stub " ++ joinPath [normalise d, normalise $ getStub ct]
- ms <- customMergeToDir (joinPath [{-normalise d,-} normalise $ getStub ct]) (fst cl) compiledDir
+ ms <- customMergeToDir (joinPath [normalise $ getStub ct]) (fst cl) compiledDir
case ms of
MergeFailure err -> do debugM ("\tMerge error : " ++ (show err))
return $ insert cl (CodeLoadFailure $ unlines err) cmap
@@ -109,7 +122,9 @@ mergeCode ct cmap cl = do
return cmap
MergeSuccess _ args fp -> do debugM ("\tMerge success : " ++ (fst cl))
makeCode ct cmap cl args fp
-
+
+
+-- | Attempt to make the code, then call the loader appropriate for the 'CodeType' (e.g. @View@ -> '_loadView').
makeCode :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> [Arg] -> FilePath -> m CodeMap
makeCode ct cmap cl args fp = do
ms <- liftIO $ makeAll fp (compileArgs++args)
@@ -126,6 +141,8 @@ makeCode ct cmap cl args fp = do
CTController -> _loadController ct cmap cl fp
CTComponentController -> _loadController ct cmap cl fp
+-- | Attempt to load the code and return the 'CodeMap' with the newly loaded code in it. This
+-- function is specialized for Views.
_loadView :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> FilePath -> m CodeMap
_loadView ct cmap cl fp = do
debugM ("_load : " ++ (show ct) ++ " : " ++ (fst cl) ++ " : " ++ (snd cl))
@@ -142,6 +159,8 @@ _loadView ct cmap cl fp = do
CTComponentView -> return (insert cl (CodeLoadComponentView f m t) cmap)
_ -> error $ "_loadView: passed an invalid CodeType (" ++ (show ct) ++ ")"
+-- | Attempt to load the code and return the 'CodeMap' with the newly loaded code in it. This
+-- function is specialized for Controllers.
_loadController :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> FilePath -> m CodeMap
_loadController ct cmap cl fp = do
debugM ("_load : " ++ (show ct) ++ " : " ++ (fst cl) ++ " : " ++ (snd cl))
@@ -162,7 +181,7 @@ _loadController ct cmap cl fp = do
-- Utility functions
-------------------------------------------------------------------------------------------------
--- Custom merge function because I don't want to have to use a custom
+-- | Custom merge function because I don't want to have to use a custom
-- version of Plugins (with HSX enabled)
customMergeToDir :: (HasEnvironment m) => FilePath -> FilePath -> FilePath -> m MergeStatus
customMergeToDir stb src dir = do
@@ -189,14 +208,8 @@ customMergeToDir stb src dir = do
return $ MergeSuccess ReComp [] outFile -- must have recreated file
-needReloadCode :: (HasEnvironment m) => FilePath -> CodeDate -> m (Bool, Bool)
-needReloadCode fp fd = do
- fe <- liftIO $ doesFileExist fp
- case fe of
- True -> do mt <- liftIO $ getModificationTime fp
- return $ (True, mt > fd)
- False-> return (False, True)
+-- | Given a 'CodeType', return the base path to the code (e.g. @CTController@ -> @App/Controllers@).
getDir :: CodeType -> FilePath
getDir ct = case ct of
CTLayout -> layoutDir
7 Turbinado/Environment/Header.hs
View
@@ -11,8 +11,15 @@ import Turbinado.Controller.Monad
import Turbinado.Environment.Types
import Turbinado.Environment.Request
+-- | Attempts to pull a HTTP header value.
getHeader :: (HasEnvironment m) => HeaderName -> m (Maybe String)
getHeader h = do e <- getEnvironment
return $ findHeader h (fromJust $ getRequest e)
+-- | Unsafe version of getHeader. Fails if the key is not found.
+getHeader_u :: (HasEnvironment m) => HeaderName -> m String
+getHeader_u h = do h' <- getHeader h
+ maybe (error $ "getHeader_u : key does not exist - \"" ++ (show h) ++ "\"")
+ return
+ h'
14 Turbinado/Environment/Params.hs
View
@@ -12,16 +12,22 @@ import Turbinado.Environment.Header
import Turbinado.Environment.Request
import Turbinado.Environment.Types
-getParam_u :: (HasEnvironment m) => String -> m String
-getParam_u p = do r <- getParam p
- return $ fromJust r
-
+-- | Attempt to get a Parameter from the Request query string
+-- or POST body.
getParam :: (HasEnvironment m) => String -> m (Maybe String)
getParam p = do r <- getParamFromQueryString p
case r of
Just r' -> return r
Nothing -> getParamFromBody p
+-- | An unsafe version of getParam. Errors if the key does not exist.
+getParam_u :: (HasEnvironment m) => String -> m String
+getParam_u p = do r <- getParam p
+ maybe (error $ "getParam_u : key does not exist - \"" ++ p ++ "\"")
+ return
+ r
+
+-- Functions used by getParam. Not exported.
getParamFromQueryString :: (HasEnvironment m) => String -> m (Maybe String)
getParamFromQueryString s = do e <- getEnvironment
let qs = uriQuery $ rqURI (fromJust $ getRequest e)
54 Turbinado/Environment/Settings.hs
View
@@ -5,7 +5,6 @@ module Turbinado.Environment.Settings (
setSetting,
getController,
clearLayout,
- getLayout,
getView
)where
@@ -16,9 +15,12 @@ import Control.Monad.State
import Data.Maybe
import Data.Char
import System.FilePath
+import Turbinado.Environment.Logger
import Turbinado.Environment.Types
import Turbinado.Controller.Monad
+-- | Used during request initialization to add the 'Settings' 'Map'
+-- to the 'Environment'.
addSettingsToEnvironment :: (HasEnvironment m) => m ()
addSettingsToEnvironment = do e <- getEnvironment
setEnvironment $ e {getSettings = Just $ M.fromList defaultSettings }
@@ -26,35 +28,63 @@ addSettingsToEnvironment = do e <- getEnvironment
------------------------------------------------------------------
-- Set/Get an individual settting
------------------------------------------------------------------
+
+-- | Attempts to pull a dynamically typed value out of the 'Settings' 'Map'.
+-- Returns @Maybe a@ where @a@ is the type inferred from usage.
+--
+-- IMPORTANT: This function will return Nothing if the type inferred does not match
+-- the type in the 'Map'. So if @1 :: Int@ is stored with a key "number",
+-- then @getSetting "number" :: 'Controller' Integer@ will return @'Controller' Nothing@.
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)
-
+-- | This function is an "unsafe" version of 'getSetting' in that this function assumes that the key
+-- *does* exist in the map. If no key exists or if the value type does not match the inferred
+-- type, this function will throw an error.
+getSetting_u :: (HasEnvironment m) => String -> m String
+getSetting_u s = do v <- getSetting s
+ maybe (error $ "getSetting_u : key does not exist - \"" ++ s ++ "\"")
+ return
+ v
+
+-- | Sets a key/value pair in the 'Settings' map.
+--
+-- IMPORTANT: the value must be
+-- Typeable. If you cannot use a Typeable (e.g. you're using a type
+-- from a library), then you can extract Typeable fields from your value
+-- and set those or you can convert your type to a Typeable type (e.g. using
+-- 'show' to convert to a String).
setSetting :: (HasEnvironment m, Typeable a) => String -> a -> m ()
setSetting k v = do e <- getEnvironment
+ debugM $ " setSetting : " ++ k
setEnvironment $ e { getSettings = Just (M.insert k (toDyn v) (fromJust $ getSettings e))}
+-- | Unsets a setting. If the key does not exist, no error is thrown.
+unsetSetting :: (HasEnvironment m) => String -> m ()
+unsetSetting k = do e <- getEnvironment
+ setEnvironment $ e { getSettings = Just (M.delete k (fromJust $ getSettings e))}
+
+-- ! The 'Settings' to use at the start of each request.
+defaultSettings :: [(String, Dynamic)]
defaultSettings = [ ("layout", toDyn "Default") ]
------------------------------------------------------------------
-- Shorthands
------------------------------------------------------------------
+-- | Returns the Controller FilePath and action/function name.
getController :: (HasEnvironment m) => m (FilePath, String)
-getController = do e <- getEnvironment
- c <- getSetting "controller"
- a <- getSetting "action"
- return $ (fromJust c,
- actionName $ fromJust a)
+getController = do c <- getSetting_u "controller"
+ a <- getSetting_u "action"
+ return $ (c,
+ actionName a)
where actionName s = (toLower $ head s) : (tail s)
+-- | Tells the 'Controller' not to use a 'Layout' for the 'View'.
clearLayout :: (HasEnvironment m) => m ()
-clearLayout = setSetting "layout" ""
-
-getLayout :: (HasEnvironment m) => m (FilePath, String)
-getLayout = (\l -> return (fromJust l, "markup")) =<< getSetting "layout"
+clearLayout = unsetSetting "layout"
+-- | Helper function used by the request handler.
getView :: (HasEnvironment m) => m (FilePath, String)
getView = do c <- getSetting_u "controller"
a <- getSetting_u "action"
12 Turbinado/Environment/Types.hs
View
@@ -16,13 +16,16 @@ import Config.Master
import System.Time
import System.Plugins
+
+-- | The class of types which hold an 'Environment'.
+-- 'View' and 'Controller' are both instances of this class.
class (MonadIO m) => HasEnvironment m where
getEnvironment :: m Environment
setEnvironment :: Environment -> m ()
--- Stuffing all Environment "types" into this file to avoid
--- recursive imports...
-
+-- | The Environment in which each request is handled.
+-- All components are held within 'Maybe's so that the
+-- Environment can be partially constructed.
data Environment = Environment { getCodeStore :: Maybe CodeStore
, getDatabase :: Maybe Database
, getLoggerLock :: Maybe LoggerLock
@@ -35,8 +38,7 @@ data Environment = Environment { getCodeStore :: Maybe CodeStore
, getAppEnvironment :: Maybe AppEnvironment
}
--- type EnvironmentFilter = Environment -> IO Environment
-
+-- | Construct a new empty 'Environment'.
newEnvironment :: Environment
newEnvironment = Environment { getCodeStore = Nothing
, getDatabase = Nothing
22 Turbinado/Environment/ViewData.hs
View
@@ -15,20 +15,40 @@ import Data.Dynamic
import Turbinado.Environment.Logger
import Turbinado.Environment.Types
+-- | Used during request initialization to add the 'ViewData' 'Map
+-- to the 'Environment'.
addViewDataToEnvironment :: (HasEnvironment m) => m ()
addViewDataToEnvironment = do e <- getEnvironment
setEnvironment $ e {getViewData = Just (M.empty :: ViewData)}
+-- | Attempts to pull a dynamically typed value out of the 'ViewData 'Map'.
+-- Returns Maybe a where a is the type inferred from usage.
+--
+-- IMPORTANT: This function will return Nothing if the type inferred does not match
+-- the type in the 'Map'. So if @1 :: Int@ is stored in the 'Map' with a key "number",
+-- then @getViewDataValue "number" :: 'Controller' Integer@ will return @'Controller' Nothing@.
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
+-- | This function is an "unsafe" version of 'getViewDataValue' in that this function assumes that the key
+-- *does* exist in the map. If no key exists or if the value type does not match the inferred
+-- type, this function will throw an error.
getViewDataValue_u :: (HasEnvironment m, Typeable a) => String -> m a
getViewDataValue_u k = do v <- getViewDataValue k
- return $ fromJust v
+ maybe (error $ "getViewDataValue_u : key does not exist - \"" ++ k ++ "\"")
+ return
+ v
+-- | Sets a key/value pair in the 'ViewData' 'Map'.
+--
+-- IMPORTANT: the value must be
+-- Typeable. If you cannot use a Typeable (e.g. you're using a type
+-- from a library), then you can extract Typeable fields from your value
+-- and set those or you can convert your type to a Typeable type (e.g. using
+-- 'show' to convert to a String).
setViewDataValue :: (HasEnvironment m, Typeable a) => String -> a -> m ()
setViewDataValue k v = do e <- getEnvironment
let vd = fromJust $ getViewData e
42 Turbinado/Server.hs
View
@@ -53,6 +53,8 @@ options =
, Option ['h','?'] ["help"] (NoArg Help) "show this message"
]
+-- | Handle a few options, then kick off the server.
+main :: IO ()
main =
do args <- getArgs
case getOpt Permute options args of
@@ -63,13 +65,18 @@ main =
header = "Usage: turbinado [OPTION]"
+-- | Starts the server, builds the basic 'Environment', builds the 'WorkerPool',
+-- starts listening on the specified port. As soon as a request is noticed,
+-- it's handed off to a 'WorkerThread' to be handled. Lather, Rinse, Repeat.
startServer :: PortNumber -> IO ()
startServer pnr
= withSocketsDo $
do e <- runController
(sequence_ $ [ addLoggerToEnvironment
, addCodeStoreToEnvironment
- , addMimeTypesToEnvironment "Config/mime.types"]
+ , addMimeTypesToEnvironment "Config/mime.types"
+ , addRoutesToEnvironment
+ ]
++ customSetupFilters
)
newEnvironment
@@ -89,6 +96,8 @@ startServer pnr
-- | Worker stuff
------------------------------------------------
+-- | The basic loop for a 'WorkerThread': get the socket from the server mainloop,
+-- receive a request, handle it, then put myself back into the 'WorkerPool'.
workerLoop :: MVar WorkerPool ->
Environment ->
Chan Socket ->
@@ -102,6 +111,8 @@ workerLoop workerPoolMVar e chan
putWorkerThread workerPoolMVar chan
mainLoop
+-- | Basic request handling: setup the 'Environment' for this request,
+-- run the real requestHandler, then ship the response back to the client.
handleRequest :: Socket -> Environment -> IO ()
handleRequest sock e
= (do mytid <- myThreadId
@@ -109,7 +120,7 @@ handleRequest sock e
, addSettingsToEnvironment
, receiveRequest sock
, tryStaticContent
- , addRoutesToEnvironment ]) e
+ ]) e
case (isResponseComplete e') of
True -> sendResponse sock e'
False -> do e'' <- runController requestHandler e'
@@ -125,14 +136,23 @@ handleRequest sock e
-- | Worker Pool stuff
------------------------------------------------
-type ExpiresTime = UTCTime
-data WorkerThread = WorkerThread ThreadId (Chan Socket)
+-- | The 'WorkerPool' holds each idle or busy 'WorkerThread'.
+-- When all 'WorkerThread's are busy, more are created by
+-- 'getWorkerThread' and added to the 'WorkerPool'.
data WorkerPool = WorkerPool { numWorkers :: Int,
idleWorkers :: [WorkerThread],
busyWorkers :: [(WorkerThread, ExpiresTime)]}
--- TODO: add a Maximum # of threads
---getWorkerThread :: MVar WorkerPool -> IO WorkerThread
+-- | Each 'WorkerThread' has a 'ThreadId' and a 'Channel' for communication.
+data WorkerThread = WorkerThread ThreadId (Chan Socket)
+
+-- | 'ExpiresTime' is the time at which a 'WorkerThread' will be killed if it
+-- has not completed its 'Request'.
+type ExpiresTime = UTCTime
+
+-- | 'getWorkerThread' returns a 'WorkerThread'. If all threads are busy,
+-- a new WorkerThread is created and returned.
+getWorkerThread :: MVar WorkerPool -> Environment -> IO WorkerThread
getWorkerThread mv e =
do wp <- takeMVar mv
case wp of
@@ -149,6 +169,9 @@ getWorkerThread mv e =
putMVar mv $ WorkerPool n idles ((idle, expiresTime):busies)
return idle
+-- | 'putWorkerThread' puts a 'WorkerThread' back into the 'WorkerPool'. This function
+-- is used by the thread to put *itself* back into the pool.
+putWorkerThread :: MVar WorkerPool -> Chan Socket -> IO ()
putWorkerThread mv chan = do
WorkerPool n is bs <- takeMVar mv
mytid <- myThreadId
@@ -156,13 +179,6 @@ putWorkerThread mv chan = do
putMVar mv $ WorkerPool n ((WorkerThread mytid chan):is) bs'
-
-timeout :: Int -> ThreadId -> IO ()
-timeout time thid
- = do threadDelay time
- throwTurbinadoTo thid TimedOut
-
--- conf. files? Indeed!
stdTimeOut :: Integer
stdTimeOut = 90
54 Turbinado/Server/Handlers/RequestHandler.hs
View
@@ -40,12 +40,25 @@ import Turbinado.View
import Turbinado.View.XML
import Turbinado.Server.StandardResponse
+-- | Filters to be run before the Controller are run
+-- (e.g. a request logger or session initializer). Filters
+-- should consider what to do if isResponseComplete. For example,
+-- the Controller and View won't run if the response is complete
+-- because they would risk overwriting the response.
+--
+-- NOTE: Custom filters are specified in Config/App.hs.
preFilters :: [Controller ()]
preFilters = [Routes.runRoutes ]
+-- | Filters to be run after the Controller and View are run.
+-- (e.g. cookie setter)
+--
+-- NOTE: Custom filters are specified in Config/App.hs.
postFilters :: [Controller ()]
postFilters = []
+-- | The main request handler. This runs standard and custom preFilters
+-- then runs the Controller and View.
requestHandler :: Controller ()
requestHandler = do
debugM $ " requestHandler : running pre and main filters"
@@ -59,31 +72,46 @@ requestHandler = do
sequence_ (customPostFilters ++ postFilters)
+-- | This function dynamically loads (if needed) the 'Controller'
+-- using the information provided by the 'Routes'. Controllers reside
+-- in @App/Controllers@.
retrieveAndRunController :: Controller ()
retrieveAndRunController =
do debugM $ " retrieveAndRunController : Starting"
- co <- getController
- p <- retrieveCode CTController co
- case p of
- CodeLoadController p' _ _ -> p'
- CodeLoadFailure e -> errorResponse e
- CodeLoadView _ _ _ -> error "retrieveAndRunController: retrieveCode called, but returned CodeLoadView"
- CodeLoadMissing -> error "retrieveAndRunController: retrieveCode called, but returned CodeLoadMissing"
+ e <- getEnvironment
+ case (isResponseComplete e) of
+ True -> do debugM $ " retrieveAndRunController : response was already complete"
+ return ()
+ False -> do co <- getController
+ p <- retrieveCode CTController co
+ case p of
+ CodeLoadController p' _ _ -> p'
+ CodeLoadFailure e -> errorResponse e
+ CodeLoadView _ _ _ -> error "retrieveAndRunController: retrieveCode called, but returned CodeLoadView"
+ CodeLoadMissing -> error "retrieveAndRunController: retrieveCode called, but returned CodeLoadMissing"
+-- | This function dynamically loads (if needed) the 'View'
+-- using the information provided by the 'Routes'. Views reside
+-- in @App/Views@ and Layouts reside in @App/Layouts.
+-- The 'View' must contain a @markup@ function.
+-- The first 'View' loaded is usually the Layout, which itself
+-- loads the actual 'View'. If the @layout@ setting is empty, then
+-- no layout is loaded and the default 'View' is loaded.
retrieveAndRunLayout :: Controller ()
retrieveAndRunLayout =
do e <- getEnvironment
case (isResponseComplete e) of
- True -> return ()
- False -> do l <- getLayout
+ True -> do debugM $ " retrieveAndRunLayout : response was already complete"
+ return ()
+ False -> do l <- getSetting "layout"
p <- case l of
- ("", _) -> do v <- getView
+ Nothing -> do v <- getView
retrieveCode CTView v -- If no Layout, then pull a View
- _ -> retrieveCode CTLayout l
+ Just l' -> retrieveCode CTLayout (l', "markup")
case p of
CodeLoadView p' _ _ -> evalView p'
CodeLoadFailure e -> errorResponse e
- CodeLoadController _ _ _ -> error "retrieveAndRunView: retrieveCode called, but returned CodeLoadController"
- CodeLoadMissing -> error "retrieveAndRunView: retrieveCode called, but returned CodeLoadMissing"
+ CodeLoadController _ _ _ -> error "retrieveAndRunLayout: retrieveCode called, but returned CodeLoadController"
+ CodeLoadMissing -> error "retrieveAndRunLayout: retrieveCode called, but returned CodeLoadMissing"
5 Turbinado/Server/Network.hs
View
@@ -16,13 +16,16 @@ import Turbinado.Environment.Response
import Network.HTTP
+-- | Read the request from client.
receiveRequest :: Socket -> Controller ()
receiveRequest sock = do
req <- liftIO $ receiveHTTP sock
case req of
- Left _ -> throwTurbinado $ BadRequest "Looks as though we've got a bad request, sir"
+ Left e -> throwTurbinado $ BadRequest $ "In receiveRequest : " ++ show e
Right r -> do e <- get
put $ e {getRequest = Just r}
+-- | Get the 'Response' from the 'Environment' and send
+-- it back to the client.
sendResponse :: Socket -> Environment -> IO ()
sendResponse sock e = respondHTTP sock $ fromJust $ getResponse e
2  Turbinado/Stubs/ComponentController.hs
View
@@ -1,5 +1,3 @@
-import Config.Master
-import Turbinado.Controller
-- SPLIT HERE
2  Turbinado/Stubs/Controller.hs
View
@@ -1,5 +1,3 @@
-import Config.Master
-import Turbinado.Controller
-- SPLIT HERE
3  scripts/GenerateModels.hs
View
@@ -4,5 +4,4 @@ import Config.Master
main = do putStrLn "Generation starting."
generateModels
- putStrLn "Generation completed."
- putStrLn "Have a gander at App/Models."
+ putStrLn "Generation completed. Models are in App/Models."
4 turbinado.cabal
View
@@ -1,5 +1,5 @@
Name: turbinado
-Version: 0.2
+Version: 0.4
Synopsis: Haskell web application server
Description: The Haskell web application server
License: BSD3
@@ -21,8 +21,8 @@ Executable turbinado
Build-Depends: base <4.0,
containers,
directory,
+ harp == 0.4,
filepath,
- harp == 0.4,
HDBC,
HDBC-postgresql,
hslogger,
Please sign in to comment.
Something went wrong with that request. Please try again.