Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Checking in all of the Environment + Website changes

  • Loading branch information...
commit c59c8d30e1e7fcddb82660415b99bfedbcbd4560 1 parent a9327b2
alson authored
Showing with 516 additions and 752 deletions.
  1. +1 −3 App/Controllers/Home.hs
  2. +47 −42 App/Layouts/Default.hs
  3. +24 −1 Config/App.hs
  4. +2 −1  Config/Routes.hs
  5. +44 −10 Turbinado/Controller.hs
  6. +8 −1 Turbinado/Controller/Monad.hs
  7. +0 −30 Turbinado/Environment.hs
  8. BIN  Turbinado/Environment/.ViewData.hs.swp
  9. +85 −111 Turbinado/Environment/CodeStore.hs
  10. +27 −26 Turbinado/Environment/Logger.hs
  11. +10 −21 Turbinado/Environment/MimeTypes.hs
  12. +7 −126 Turbinado/Environment/Request.hs
  13. +8 −131 Turbinado/Environment/Response.hs
  14. +16 −29 Turbinado/Environment/Routes.hs
  15. +28 −35 Turbinado/Environment/Settings.hs
  16. +30 −20 Turbinado/Environment/ViewData.hs
  17. +10 −9 Turbinado/Layout.hs
  18. +18 −22 Turbinado/Server.hs
  19. +25 −23 Turbinado/Server/Handlers/ErrorHandler.hs
  20. +35 −53 Turbinado/Server/Handlers/RequestHandler.hs
  21. +9 −6 Turbinado/Server/Network.hs
  22. +46 −16 Turbinado/Server/StandardResponse.hs
  23. +15 −13 Turbinado/Server/StaticContent.hs
  24. +2 −0  Turbinado/Stubs/Controller.hs
  25. +10 −10 Turbinado/View.hs
  26. +2 −1  Turbinado/View/Helpers/Misc.hs
  27. +5 −3 Turbinado/View/Monad.hs
  28. +0 −6 static/css/turbinado.css
  29. +2 −3 turbinado.cabal
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
89 App/Layouts/Default.hs
@@ -1,53 +1,58 @@
+import Control.Monad.Trans
+import Data.List
+import Data.Maybe
+import qualified Network.HTTP as HTTP
+import qualified Network.URI as URI
+
page :: View XML
page = <html>
<head>
<% styleSheet "normalize" "screen" %>
- <% styleSheet "jsddm" "screen" %>
+ <% styleSheet "pressurized" "screen" %>
<% styleSheet "turbinado" "screen" %>
<% javaScript "jquery" %>
<% javaScript "jsddm" %>
- <script type="text/javascript">
- var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");
- document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));
- </script>
- <script type="text/javascript">
- var pageTracker = _gat._getTracker("UA-6158816-1");
- pageTracker._trackViewview();
- </script>
+ <% googleAnalytics "UA-6158816-1" %>
</head>
<body>
- <table class="wrapper">
- <tr>
- <td class="title">
- <h1>Turbinado</h1>
- <img class="title-image" src="/images/turbinado.jpg" />
- <h2>Sugar For</h2>
- <h2>The Web</h2>
- </td>
- <td class="container">
- <ul id="jsddm">
- <li><a href="/Home/Index">Home</a>
- <ul>
- <li><a href="/Home/About">About</a></li>
- <li><a href="/Home/Performance">Performance</a></li>
- </ul>
- </li>
- <li><a href="/Tutorial/Index">Tutorial</a>
- </li>
- <li><a href="/Develop/Index">Develop</a></li>
- </ul>
- <div class="clear"></div>
- <% breadCrumbs %>
- <div id="content-block" class="content-block">
- <% insertView %>
- </div>
- </td>
- </tr>
- <tr>
- <td colspan="2">
- <div class="footer">Turbinado - www.turbinado.org</div>
- </td>
- </tr>
- </table>
+ <div id="wrapper">
+ <div id="header">
+ <div id="logo">
+ <h1>
+ <a href="http://www.turbinado.org">
+ <img src="/images/turbinado.jpg" />
+ <span style="left:140px; position:absolute; top:65px;">
+ Turbinado
+ </span>
+ </a>
+ </h1>
+ </div>
+ </div>
+ <div id="menu">
+ <ul>
+ <% menuItem "/Home/Index" "Home" %>
+ <% menuItem "/Home/About" "About" %>
+ <% menuItem "/Home/Performance" "Performance" %>
+ <% menuItem "/Tutorial/Index" "Tutorial" %>
+ <% menuItem "/Develop/Index" "Develop" %>
+ </ul>
+ </div>
+ <div id="page">
+ <div id="content">
+ <% insertView %>
+ </div>
+ </div>
+ <div style="clear: both;" />
+ </div>
+ <div id="footer">
+ <p>Copyright (c) 2008 Turbinado.org. All rights reserved.</p>
+ <p>Design by <a href="http://www.freecsstemplates.org/">Free CSS Templates</a>.</p>
+ </div>
</body>
</html>
+
+menuItem :: FilePath -> String -> View XML
+menuItem p t = do e <- getEnvironment
+ let ru = HTTP.rqURI $ fromJust $ getRequest e
+ active = if isPrefixOf p (URI.uriPath ru) then "active" else ""
+ <li class=active><a href=p><%t%></a></li>
View
25 Config/App.hs
@@ -1,13 +1,36 @@
-module Config.App where
+module Config.App (
+ applicationPath,
+ applicationHost,
+ AppEnvironment (..),
+ newAppEnvironment,
+ databaseConnection,
+ Connection,
+ customPreFilters,
+ customPostFilters,
+ logLevel
+ ) where
import System.Log.Logger
+-- Your favorite HDBC driver
+import Database.HDBC.PostgreSQL
+
----------------------------------------------------------------
-- Environment settings
----------------------------------------------------------------
applicationPath = ""
applicationHost = "localhost:8080"
+data AppEnvironment = AppEnvironment
+newAppEnvironment = AppEnvironment
+
+----------------------------------------------------------------
+-- Database connection
+----------------------------------------------------------------
+databaseConnection :: Maybe (IO Connection)
+databaseConnection = Just $ connectPostgreSQL "host=localhost dbname=turbinado user=turbinado password=turbinado"
+
+
----------------------------------------------------------------
-- RequestHandler Filter List additions
----------------------------------------------------------------
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
30 Turbinado/Environment.hs
@@ -1,30 +0,0 @@
-module Turbinado.Environment (
- Environment,
- EnvironmentFilter,
- newEnvironment,
- getKey,
- setKey
- ) where
-
-import Data.Dynamic
-import Data.Map
-import Data.Maybe
-import System.IO
-import System.IO.Unsafe
-import System.Log.Logger
-
--- 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
-
-type EnvironmentFilter = Environment -> IO Environment
-
-newEnvironment :: IO Environment
-newEnvironment = return (empty :: Environment)
-
-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
BIN  Turbinado/Environment/.ViewData.hs.swp
Binary file not shown
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
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
133 Turbinado/Environment/Request.hs
@@ -1,138 +1,19 @@
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
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
19 Turbinado/Layout.hs
@@ -4,10 +4,11 @@ module Turbinado.Layout (
javaScript,
googleAnalytics
) where
-
+import Control.Monad.State
+import Control.Monad.Trans
import Data.Maybe
import Data.Dynamic
-import Turbinado.Environment
+import Turbinado.Environment.Types
import Turbinado.Environment.CodeStore
import Turbinado.Environment.Logger
import Turbinado.Environment.Settings
@@ -15,15 +16,15 @@ import Turbinado.View
insertView :: View XML
insertView = do e <- getEnvironment
- let cs = getCodeStore e
- cl = getView e
- doIO $ debugM e $ " Layout: insertView : loading " ++ (fst cl) ++ " - " ++ (snd cl)
- c <- doIO $ retrieveCode e CTView cl
+ let cs = fromJust $ getCodeStore e
+ cl <- lift getView
+ --debugM $ " Layout: insertView : loading " ++ (fst cl) ++ " - " ++ (snd cl)
+ c <- lift $ retrieveCode CTView cl
case c of
CodeLoadView v _ _ -> v
CodeLoadController _ _ _ -> error "retrieveAndRunLayout called, but returned CodeLoadController"
- CodeLoadFailure -> return $ cdata $ "CodeLoadFailure: insertView : " ++ (show $ fst $ getView e) ++ " - " ++ (show $ snd $ getView e)
-
+ CodeLoadFailure -> return $ cdata $ "CodeLoadFailure: insertView "
+
styleSheet :: String -> String -> View XML
styleSheet s m = return $ cdata $ "<link media=\"" ++ m ++"\" type=\"text/css\" rel=\"stylesheet\" href=\"/css/" ++ s ++".css\">"
@@ -39,5 +40,5 @@ googleAnalytics g = return $ cdata $
"</script> " ++
"<script type=\"text/javascript\"> " ++
" var pageTracker = _gat._getTracker(\"" ++ g ++ "\"); " ++
- " pageTracker._trackViewview(); " ++
+ " pageTracker._trackPageview(); " ++
"</script> "
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!"
- debugM e "Generating output ... "
- hds <- Response.getHeaders resp
- let body = HSP.renderXML xml
- debugM e "Done!"
- where paths hreq =
- let u = HTTP.rqURI hreq
- p = uriPath u
- dirp = reverse $ dropWhile (/='/') $ reverse p
- in (rootDir ++ p, rootDir ++ dirp)
--}
View
15 Turbinado/Server/Network.hs
@@ -3,23 +3,26 @@ module Turbinado.Server.Network (
, sendResponse -- :: Handle -> Response -> IO ()
) where
+import Data.Maybe
import Network.Socket
+import Turbinado.Controller.Monad
import Turbinado.Server.Exception
import Turbinado.Environment.Logger
-import Turbinado.Environment
+import Turbinado.Environment.Types
import Turbinado.Environment.Request
import Turbinado.Environment.Response
import Network.HTTP
-receiveRequest :: Socket -> EnvironmentFilter
-receiveRequest sock e = do
- req <-receiveHTTP sock
+receiveRequest :: Socket -> Controller ()
+receiveRequest sock = do
+ req <- doIO $ receiveHTTP sock
case req of
Left _ -> throwTurbinado $ BadRequest "Looks as though we've got a bad request, sir"
- Right r -> setRequest r e
+ Right r -> do e <- get
+ put $ e {getRequest = Just r}
sendResponse :: Socket -> Environment -> IO ()
-sendResponse sock e = respondHTTP sock $ getResponse e
+sendResponse sock e = respondHTTP sock $ fromJust $ getResponse e
View
62 Turbinado/Server/StandardResponse.hs
@@ -13,44 +13,74 @@
-----------------------------------------------------------------------------
module Turbinado.Server.StandardResponse where
+import Data.List
import Network.HTTP
import Network.HTTP.Headers
-import Turbinado.Environment
+import System.Locale
+import System.Time
+
+import Turbinado.Environment.Types
import Turbinado.Environment.Response
+import Turbinado.Controller.Monad
-- import HSP.Data
+instance Eq Header where
+ (==) (Header hn1 _) (Header hn2 _) = hn1 == hn2
-fileNotFoundResponse :: FilePath -> EnvironmentFilter
-fileNotFoundResponse fp =
- setResponse (Response (4,0,0) "File Not Found" (contentHds $ length body) (body))
+fileNotFoundResponse :: FilePath -> Controller ()
+fileNotFoundResponse fp =
+ do t <- doIO $ 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 -> EnvironmentFilter
+cachedContentResponse :: Int -> String -> String -> Controller ()
cachedContentResponse age ct body =
- pageResponse [ Header HdrCacheControl $ "max-age=" ++ (show age) ++ ", public"
- , Header HdrContentType ct] body
+ do t <- doIO $ getClockTime
+ pageResponse (buildHeaders
+ Nothing t
+ [Header HdrCacheControl $ "max-age=" ++ (show age) ++ ", public"
+ , Header HdrContentType ct])
+ body
-pageResponse :: [Header] -> String -> EnvironmentFilter
+pageResponse :: [Header] -> String -> Controller ()
pageResponse hds body =
+ do t <- doIO $ getClockTime
setResponse (Response stSuccess "OK"
- (contentHds (length body) ++ hds) (body))
+ (buildHeaders (Just $ length body) t hds) (body))
+
+redirectResponse :: String -> Controller ()
+redirectResponse l =
+ do t <- doIO $ getClockTime
+ setResponse (Response (3,0,2) "OK" (buildHeaders Nothing t [Header HdrLocation l]) "")
-errorResponse :: String -> EnvironmentFilter
+errorResponse :: String -> Controller ()
errorResponse err =
+ do t <- doIO $ getClockTime
setResponse (Response stError "Internal Server Error"
- (contentHds $ length body) (body))
+ (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 :: EnvironmentFilter
+badReqResponse :: Controller ()
badReqResponse =
+ do t <- doIO $ getClockTime
setResponse (Response stBadReq "Bad Request"
- (contentHds $ length body) (body))
+ (buildHeaders (Just $ length body) t []) body)
where body = "<html><body>\n <p><big>400 Bad Request</big></p>\n </body></html>"
-contentHds :: Int -> [Header]
-contentHds l = [Header HdrContentType"text/html",
- Header HdrContentLength $ show l]
+buildHeaders :: Maybe Int -> ClockTime -> [Header] -> [Header]
+buildHeaders Nothing t hdrs = union hdrs ( startingHeaders t)
+buildHeaders (Just l) t hdrs = union hdrs ((startingHeaders t) ++
+ [Header HdrContentLength $ show l])
+
+
+startingHeaders t = [ Header HdrServer "Turbinado www.turbinado.org"
+ , Header HdrContentType "text/html; charset=UTF-8"
+ , Header HdrDate $ formatCalendarTime defaultTimeLocale rfc822DateFormat $ toUTCTime t
+ ]
stSuccess, stFNF :: ResponseCode
stSuccess = (2,0,0)
View
28 Turbinado/Server/StaticContent.hs
@@ -12,31 +12,33 @@ import Prelude hiding (catch)
import Network.URI
import Network.HTTP
+import Turbinado.Controller.Monad
import Turbinado.Server.StandardResponse
import Turbinado.Environment.MimeTypes
-import Turbinado.Environment
+import Turbinado.Environment.Types
import Turbinado.Environment.Logger
import Turbinado.Environment.Request
import Turbinado.Environment.Response
import Config.Master
-tryStaticContent :: EnvironmentFilter
-tryStaticContent e =
- do cDir <- getCurrentDirectory
- let mt = getMimeTypes e
- rq = getRequest e
+tryStaticContent :: Controller ()
+tryStaticContent =
+ do e <- get
+ cDir <- doIO $ getCurrentDirectory
+ let mt = fromJust $ getMimeTypes e
+ rq = fromJust $ getRequest e
f = drop 1 $ uriPath $ rqURI rq
trydirs = case (length f) of
0 -> map (\s -> joinPath $ map normalise [cDir, s, "index.html"]) staticDirs
_ -> map (\s -> joinPath $ map normalise [cDir, s, f]) staticDirs
-- debugM e $ " tryStaticContent over " ++ (show trydirs)
- foldl ( >>= ) (return e) $ map (tryToGetStaticContent mt) trydirs
+ sequence_ $ map (tryToGetStaticContent mt) trydirs
-tryToGetStaticContent :: MimeTypes -> FilePath -> EnvironmentFilter
-tryToGetStaticContent mt p e = do exist <- doesFileExist p
- case exist of
- False -> return e
- True -> do f <- readFile p
+tryToGetStaticContent :: MimeTypes -> FilePath -> Controller ()
+tryToGetStaticContent mt p = do exist <- doIO $ doesFileExist p
+ case exist of
+ False -> return ()
+ True -> do f <- doIO $ readFile p
let ct = maybe "text/html" (show) (mimeTypeOf mt p)
- cachedContentResponse 600 ct f e
+ cachedContentResponse 600 ct f
View
2  Turbinado/Stubs/Controller.hs
@@ -2,3 +2,5 @@ import Config.Master
import Turbinado.Controller
-- SPLIT HERE
+
+
View
20 Turbinado/View.hs
@@ -16,11 +16,11 @@ module Turbinado.View (
module Turbinado.View.XML,
module Turbinado.View.XML.PCDATA,
module Turbinado.View.XMLGenerator,
- module Turbinado.Environment,
module Turbinado.Environment.CodeStore,
module Turbinado.Environment.Request,
module Turbinado.Environment.Response,
module Turbinado.Environment.Settings,
+ module Turbinado.Environment.Types
) where
import Control.Exception (catchDyn)
@@ -34,26 +34,26 @@ import qualified Network.URI as URI
import Prelude hiding (catch)
import System.FilePath
-import Turbinado.Environment
+import Turbinado.Controller.Monad hiding (catch)
+import Turbinado.Environment.CodeStore
import Turbinado.Environment.Request
import Turbinado.Environment.Response
import Turbinado.Environment.Settings
+import Turbinado.Environment.Types
+import Turbinado.Server.StandardResponse
import Turbinado.View.Exception
import Turbinado.View.HTML
-import Turbinado.View.Monad
+import Turbinado.View.Monad hiding (doIO)
import Turbinado.View.XML hiding (Name)
import Turbinado.View.XML.PCDATA
import Turbinado.View.XMLGenerator
-import Turbinado.Environment.CodeStore
import Turbinado.Utility.General
-evalView :: View XML -> EnvironmentFilter
-evalView p e =
- do (x, e') <- runView p e
- case (HTTP.rspCode $ getResponse e') of
- (0,0,0) -> setResponse ((getResponse e) {HTTP.rspCode = (2,0,0), HTTP.rspBody = renderAsHTML x}) e'
- _ -> return e'
+evalView :: View XML -> Controller ()
+evalView p = do e <- get
+ (x, e') <- doIO $ runView p e
+ pageResponse [] $ renderAsHTML x
defaultContentType :: String
defaultContentType = "text/html; charset=ISO-8859-1"
View
3  Turbinado/View/Helpers/Misc.hs
@@ -3,6 +3,7 @@ module Turbinado.View.Helpers.Misc (
) where
import Data.List
+import Data.Maybe
import qualified Network.URI as URI
import qualified Network.HTTP as HTTP
import System.FilePath
@@ -13,6 +14,6 @@ import Turbinado.View
breadCrumbs :: View XML
breadCrumbs = do e <- getEnvironment
- let r = getRequest e
+ let r = fromJust $ getRequest e
ps = tail $ splitDirectories $ URI.uriPath $ rqURI r
return $ cdata $"<div class='breadcrumbs'>" ++ (concat $ intersperse " : " ps) ++ "</div>"
View
8 Turbinado/View/Monad.hs
@@ -2,6 +2,8 @@ module Turbinado.View.Monad (
-- * The 'View' Monad
View, ViewT, ViewT',
runView, runViewT,
+ get,
+ put,
-- * Functions
doIO, catch
) where
@@ -15,7 +17,7 @@ import HSX.XMLGenerator (XMLGenT(..), unXMLGenT)
import qualified Network.HTTP as HTTP
import Prelude hiding (catch)
-import Turbinado.Environment
+import Turbinado.Environment.Types
import Turbinado.View.Exception
import Turbinado.Utility.General
@@ -25,7 +27,7 @@ import Turbinado.Utility.General
-- | The View monad is a reader wrapper around
-- the IO monad, but extended with an XMLGenerator wrapper.
-
+-- View = XMLGenT (StateT Environment IO) a
type View = ViewT IO
type ViewT' m = StateT Environment m
@@ -39,7 +41,7 @@ dummyEnv = undefined
runView :: View a -> Environment -> IO (a, Environment)
runView p e = runStateT (unXMLGenT p) e
-runViewT :: ViewT IO a -> Environment -> IO (a, Environment)
+runViewT :: ViewT IO a -> Environment -> IO (a, Environment)
runViewT = runStateT . unXMLGenT
-- | Execute an IO computation within the View monad.
View
6 static/css/turbinado.css
@@ -1,5 +1,4 @@
h1 {
- padding-top: 10px;
font-weight: bold;
font-size: 16px;
}
@@ -45,11 +44,6 @@ div.content-block {
min-height: 500px;
}
-body {
- margin: 20px 0;
- font-family: Tahoma, sans-serif;
- background-color: #D4E0F2;
-}
.title {
text-align: center;
View
5 turbinado.cabal
@@ -10,9 +10,8 @@ Build-Type: Simple
Executable server
Main-is: Turbinado/Server.hs
- Build-Depends: base, bytestring, containers, directory, filepath, harp, hslogger, hsx, HTTP, mtl, network, old-locale, old-time, parsec, plugins, pretty, regex-compat, time
- Hs-Source-Dirs: . , config
- ghc-options: -F -pgmFtrhsx -O
+ Build-Depends: base, bytestring, containers, directory, filepath, harp, HDBC, HDBC-postgresql, hslogger, hsx, HTTP, mtl, network, old-locale, old-time, pandoc, parsec, plugins, pretty, regex-compat, time
+ ghc-options: -F -pgmFtrhsx -O
Extensions: MultiParamTypeClasses,
FunctionalDependencies,
TypeFamilies,
Please sign in to comment.
Something went wrong with that request. Please try again.