Skip to content
This repository
Browse code

Updating to match turbinado-website

  • Loading branch information...
commit da95eda271763e881bce81e751f4f89bc46e334a 1 parent 4c5c1b2
Alson Kemp authored

Showing 40 changed files with 805 additions and 451 deletions. Show diff stats Hide diff stats

  1. 32  Config/App.hs.sample
  2. 18  Config/Database.hs.sample
  3. 4  Config/Master.hs
  4. 7  Config/Routes.hs
  5. 34  Config/Routes.hs.sample
  6. 4  README
  7. 4  Turbinado/Controller.hs
  8. 42  Turbinado/Controller/Routes.hs
  9. 2  Turbinado/Database/ORM/Generator.hs
  10. 36  Turbinado/Database/ORM/Output.hs
  11. 31  Turbinado/Environment/CodeStore.hs
  12. 178  Turbinado/Environment/Cookie.hs
  13. 5  Turbinado/Environment/Database.hs
  14. 3  Turbinado/Environment/Header.hs
  15. 5  Turbinado/Environment/Logger.hs
  16. 7  Turbinado/Environment/Params.hs
  17. 4  Turbinado/Environment/Response.hs
  18. 42  Turbinado/Environment/Routes.hs
  19. 132  Turbinado/Environment/Session.hs
  20. 161  Turbinado/Environment/Session/CookieSession.hs
  21. 22  Turbinado/Environment/Settings.hs
  22. 78  Turbinado/Environment/Types.hs
  23. 5  Turbinado/Environment/ViewData.hs
  24. 30  Turbinado/Layout.hs
  25. 8  Turbinado/Layout/Helpers.hs
  26. 12  Turbinado/Layout/Helpers/Misc.hs
  27. 10  Turbinado/Layout/Helpers/Tags.hs
  28. 76  Turbinado/Server.hs
  29. 8  Turbinado/Server/{Handlers → }/ErrorHandler.hs
  30. 26  Turbinado/Server/Handlers/SessionHandler.hs
  31. 75  Turbinado/Server/Network.hs
  32. 12  Turbinado/Server/{Handlers/RequestHandler.hs → RequestProcess.hs}
  33. 63  Turbinado/Server/StandardResponse.hs
  34. 9  Turbinado/Utility/Data.hs
  35. 35  Turbinado/Utility/Naming.hs
  36. 2  Turbinado/View.hs
  37. 8  Turbinado/View/Helpers/Misc.hs
  38. 16  Turbinado/View/Helpers/Tags.hs
  39. 4  static/dispatch.cgi
  40. 6  turbinado.cabal
32  Config/App.hs.sample
... ...
@@ -1,9 +1,5 @@
1 1
 module Config.App (
2  
-  applicationPath,
3  
-  applicationHost,
4  
-  AppEnvironment (..),
5  
-  newAppEnvironment,
6  
-  databaseConnection,
  2
+  useLowerCasePaths,
7 3
   Connection,
8 4
   customSetupFilters,
9 5
   customPreFilters,
@@ -16,28 +12,34 @@ import System.Log.Logger
16 12
 -- Your favorite HDBC driver
17 13
 import Database.HDBC.PostgreSQL
18 14
 
  15
+import Turbinado.Controller.Monad
  16
+import Turbinado.Environment.Types
  17
+import Turbinado.Environment.Session.CookieSession
  18
+
19 19
 ----------------------------------------------------------------
20 20
 -- Environment settings
21 21
 ----------------------------------------------------------------
22  
-applicationPath = ""
23  
-applicationHost = "localhost:8080"
24 22
 
25  
-data AppEnvironment = AppEnvironment
26  
-newAppEnvironment = AppEnvironment
  23
+-- | Determines whether the server uses URLs of the form FooBar/BimBam or foo_bar/bim_bam.
  24
+-- The Controllers and Views must still be named FooBar.hs and BimBam.hs.
  25
+useLowerCasePaths = True
27 26
 
28 27
 ----------------------------------------------------------------
29  
--- Database connection
  28
+-- Session settings
30 29
 ----------------------------------------------------------------
31  
-databaseConnection :: Maybe (IO Connection)
32  
--- databaseConnection = Nothing
33  
-databaseConnection = Just $ connectPostgreSQL "host=localhost dbname=turbinado user=turbinado password=turbinado"
  30
+sessionOpts = [ ("cookie-name", "turb-sess")
  31
+              , ("cipher-key",  "super secret phrase")
  32
+              ]
34 33
 
35 34
 ----------------------------------------------------------------
36 35
 -- RequestHandler Filter List additions
37 36
 ----------------------------------------------------------------
  37
+customSetupFilters :: [Controller ()]
38 38
 customSetupFilters  = []
39  
-customPreFilters  = []
40  
-customPostFilters = []
  39
+customPreFilters   :: [Controller ()]
  40
+customPreFilters    = [retrieveSession sessionOpts]
  41
+customPostFilters  :: [Controller ()]
  42
+customPostFilters   = [persistSession  sessionOpts]
41 43
 
42 44
 
43 45
 ----------------------------------------------------------------
18  Config/Database.hs.sample
... ...
@@ -0,0 +1,18 @@
  1
+module Config.Database (
  2
+  databaseConnection,
  3
+  ) where
  4
+
  5
+import System.Log.Logger
  6
+
  7
+-- Your favorite HDBC driver
  8
+import Database.HDBC.PostgreSQL
  9
+
  10
+import Turbinado.Environment.Types
  11
+----------------------------------------------------------------
  12
+-- Database connection
  13
+----------------------------------------------------------------
  14
+-- databaseConnection :: Maybe (IO Connection)
  15
+-- databaseConnection = Nothing
  16
+databaseConnection = Just $ connectPostgreSQL "host=localhost dbname=turbinado user=turbinado password=turbinado"
  17
+
  18
+
4  Config/Master.hs 100644 → 100755
... ...
@@ -1,9 +1,11 @@
1 1
 module Config.Master (
2 2
         module Config.Master,
3  
-        module Config.App
  3
+        module Config.App,
  4
+        module Config.Database
4 5
         ) where
5 6
 
6 7
 import Config.App
  8
+import Config.Database
7 9
 
8 10
 ----------------------------------------------------------------
9 11
 -- Arguments to the make system used in the Dynamic Loader
7  Config/Routes.hs
... ...
@@ -1,7 +0,0 @@
1  
-module Config.Routes where
2  
-
3  
-routes = [ "/:controller/:action/:id"
4  
-         , "/:controller/:action.:format"
5  
-         , "/:controller/:action"
6  
-         , "/:controller"
7  
-         ]
34  Config/Routes.hs.sample
... ...
@@ -1,7 +1,39 @@
1 1
 module Config.Routes where
2 2
 
3  
-routes = [ "/:controller/:action/:id"
  3
+--
  4
+-- Import modules for which you'll be creating static routes.
  5
+--
  6
+import App.Layouts.Default
  7
+import App.Controllers.Home
  8
+import App.Controllers.Develop
  9
+import App.Views.Home.Index
  10
+import App.Views.Develop.Index
  11
+
  12
+--
  13
+-- Configure dynamic routes for on-the-fly compiled-and-loaded
  14
+-- modules (ala Rails)
  15
+--
  16
+routes = [ "/:controller/:action/:id.:format"
  17
+         , "/:controller/:action/:id"
4 18
          , "/:controller/:action.:format"
5 19
          , "/:controller/:action"
6 20
          , "/:controller"
  21
+         , "/home"
7 22
          ]
  23
+
  24
+--
  25
+-- Statically compile and load these Layouts, Controllers and Views
  26
+--
  27
+staticLayouts =
  28
+    [ ("App/Layouts/Default.hs",     "markup", App.Layouts.Default.markup)
  29
+    ]
  30
+
  31
+staticControllers = 
  32
+    [ ("App/Controllers/Home.hs",    "index", App.Controllers.Home.index)
  33
+    , ("App/Controllers/Develop.hs", "index", App.Controllers.Develop.index)
  34
+    ]
  35
+
  36
+staticViews =
  37
+    [ ("App/Views/Home/Index.hs",    "markup", App.Views.Home.Index.markup)
  38
+    , ("App/Views/Develop/Index.hs", "markup", App.Views.Develop.Index.markup)
  39
+    ]
4  README 100644 → 100755
... ...
@@ -1 +1,3 @@
1  
-Turbinado is a stab at producing a Rails-ish MVC web framework for Haskell.  A very early stab...
  1
+Turbinado is a Rails-ish MVC web framework for Haskell.  
  2
+See the homepage @ http://www.turbinado.org
  3
+
4  Turbinado/Controller.hs
@@ -21,7 +21,9 @@ module Turbinado.Controller (
21 21
         module Data.Maybe,
22 22
 
23 23
         module Config.Master,
  24
+        module Turbinado.Controller.Routes,
24 25
         module Turbinado.Environment.CodeStore,
  26
+        module Turbinado.Environment.Cookie,
25 27
         module Turbinado.Environment.Header,
26 28
         module Turbinado.Environment.Logger,
27 29
         module Turbinado.Environment.Params,
@@ -43,6 +45,7 @@ import qualified Database.HDBC as HDBC
43 45
 
44 46
 import Config.Master
45 47
 import Turbinado.Environment.CodeStore
  48
+import Turbinado.Environment.Cookie
46 49
 import Turbinado.Environment.Database
47 50
 import Turbinado.Environment.Header
48 51
 import Turbinado.Environment.Logger
@@ -53,6 +56,7 @@ import Turbinado.Environment.Settings
53 56
 import Turbinado.Environment.Types
54 57
 import Turbinado.Environment.ViewData
55 58
 import Turbinado.Controller.Monad
  59
+import Turbinado.Controller.Routes
56 60
 import Turbinado.Utility.General
57 61
 import Turbinado.Server.StandardResponse
58 62
 
42  Turbinado/Controller/Routes.hs
... ...
@@ -0,0 +1,42 @@
  1
+-----------------------------------------------------------------------------
  2
+-- |
  3
+-- Module      :  Turbinado.Controller.Routes
  4
+-- Copyright   :  (c) Alson Kemp 2009
  5
+-- License     :  BSD-style (see the file LICENSE)
  6
+-- 
  7
+-- Maintainer  :  Alson Kemp (alson@alsonkemp.com)
  8
+-- Stability   :  experimental
  9
+-----------------------------------------------------------------------------
  10
+module Turbinado.Controller.Routes (
  11
+  checkFormats
  12
+  ) where
  13
+
  14
+import Data.Maybe
  15
+import Network.HTTP.Headers
  16
+
  17
+import Turbinado.Environment.MimeTypes
  18
+import Turbinado.Environment.Request
  19
+import Turbinado.Environment.Response
  20
+import Turbinado.Environment.Settings
  21
+import Turbinado.Environment.Types
  22
+import Turbinado.Controller.Monad
  23
+
  24
+-- | Automates the process of responding to various file formats
  25
+checkFormats:: Controller ()
  26
+checkFormats = do f' <- getSetting "format"
  27
+                  case f' of
  28
+                    Nothing -> return ()
  29
+                    Just f  -> do clearLayout
  30
+                                  oldAction <- getSetting_u "action"
  31
+                                  setSetting "action" (oldAction ++ f)
  32
+                                  e <- getEnvironment
  33
+                                  let mts = fromJust $ getMimeTypes e
  34
+                                      mt  = mimeTypeOf mts f
  35
+                                      rsp = fromJust $ getResponse e
  36
+                                  case mt of 
  37
+                                    Nothing  -> return ()
  38
+                                    Just (MimeType s1 s2) -> setResponse $
  39
+                                                              replaceHeader
  40
+                                                                HdrContentType 
  41
+                                                                (s1 ++ "/" ++ s2)
  42
+                                                                rsp
2  Turbinado/Database/ORM/Generator.hs 100644 → 100755
@@ -8,7 +8,7 @@ import qualified Data.Map as M
8 8
 import Data.Maybe
9 9
 import Database.HDBC
10 10
 
11  
-import Config.Master
  11
+import Config.Database
12 12
 import Turbinado.Database.ORM.Types
13 13
 import Turbinado.Database.ORM.Output
14 14
 import Turbinado.Database.ORM.PostgreSQL
36  Turbinado/Database/ORM/Output.hs 100644 → 100755
... ...
@@ -1,3 +1,4 @@
  1
+
1 2
 module Turbinado.Database.ORM.Output where
2 3
 
3 4
 import qualified Data.Char
@@ -49,15 +50,15 @@ generateType t typeName pk ts cs =
49 50
   , ""
50 51
   , "import App.Models.Bases.Common"
51 52
   , "import Data.Maybe"
  53
+  , "import Data.Time"
52 54
   , "import Data.Typeable"
53  
-  , "import System.Time"
54 55
   , ""
55 56
   ] ++
56 57
   ["-- The data type for this model"] ++
57 58
   [ "data " ++ typeName ++ " = " ++ typeName ++ " {"
58 59
   ] ++
59 60
   [intercalate ",\n" (map columnToFieldLabel (M.toList cs))] ++
60  
-  [ "    } deriving (Eq, Show, Typeable)"
  61
+  [ "    } deriving (Show, Typeable)"
61 62
   , ""
62 63
   , "instance DatabaseModel " ++ typeName ++ " where"
63 64
   , "    tableName _ = \"" ++ t ++ "\""
@@ -83,7 +84,7 @@ generateFunctions t typeName pk ts cs =
83 84
   , "import App.Models.Bases.Common"
84 85
   , "import qualified Database.HDBC as HDBC"
85 86
   , "import Data.Maybe"
86  
-  , "import System.Time"
  87
+  , "import Data.Time"
87 88
   , ""
88 89
   , " -- My type"
89 90
   , "import App.Models.Bases." ++ typeName ++ "Type"
@@ -123,7 +124,7 @@ generateRelations t typeName pk ts cs =
123 124
   , "import App.Models.Bases.Common"
124 125
   , "import qualified Database.HDBC as HDBC"
125 126
   , "import Data.Maybe"
126  
-  , "import System.Time"
  127
+  , "import Data.Time"
127 128
   , ""
128 129
   , " -- Model imports"
129 130
   , "import App.Models.Bases." ++ typeName ++ "Type"
@@ -382,6 +383,7 @@ maybeColumnLabel :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) ->
382 383
 maybeColumnLabel (_, (_, _, True)) = "Maybe "  -- Does the column have a default
383 384
 maybeColumnLabel (_, (desc, _, _)) = if ((colNullable desc) == Just True) then "Maybe " else ""
384 385
 
  386
+-- Derived from hdbc-postgresql/Database/PostgreSQL/Statement.hs and hdbc/Database/HDBC/SqlValue.hs
385 387
 getHaskellTypeString :: SqlTypeId -> String
386 388
 getHaskellTypeString    SqlCharT = "String"
387 389
 getHaskellTypeString    SqlVarCharT = "String"
@@ -391,19 +393,25 @@ getHaskellTypeString    SqlWVarCharT = "String"
391 393
 getHaskellTypeString    SqlWLongVarCharT = "String"
392 394
 getHaskellTypeString    SqlDecimalT = "Rational"
393 395
 getHaskellTypeString    SqlNumericT = "Rational"
  396
+getHaskellTypeString    SqlTinyIntT = "Int32"
394 397
 getHaskellTypeString    SqlSmallIntT ="Int32"
395 398
 getHaskellTypeString    SqlIntegerT = "Int32"
396  
-getHaskellTypeString    SqlRealT = "Rational"
397  
-getHaskellTypeString    SqlFloatT = "Float"
  399
+getHaskellTypeString    SqlBigIntT = "Integer"
  400
+getHaskellTypeString    SqlRealT = "Double"
  401
+getHaskellTypeString    SqlFloatT = "Double"
398 402
 getHaskellTypeString    SqlDoubleT = "Double"
399  
-getHaskellTypeString    SqlTinyIntT = "Int32"
400  
-getHaskellTypeString    SqlBigIntT = "Int64"
401  
-getHaskellTypeString    SqlDateT = "ClockTime"
402  
-getHaskellTypeString    SqlTimeT = "ClockTime"
403  
-getHaskellTypeString    SqlTimestampT = "ClockTime"
404  
-getHaskellTypeString    SqlUTCDateTimeT = "ClockTime"
405  
-getHaskellTypeString    SqlUTCTimeT = "TimeDiff"
406  
-getHaskellTypeString    _ = error "Don't know how to translate this SqlTypeId to a SqlValue"
  403
+getHaskellTypeString    SqlBitT = "Bool"
  404
+getHaskellTypeString    SqlDateT = "Day"
  405
+getHaskellTypeString    SqlTimestampWithZoneT = "ZonedTime"
  406
+getHaskellTypeString    SqlTimestampT = "UTCTime"
  407
+getHaskellTypeString    SqlUTCDateTimeT = "UTCTime"
  408
+getHaskellTypeString    SqlTimeT = "TimeOfDay"
  409
+getHaskellTypeString    SqlUTCTimeT = "TimeOfDay"
  410
+getHaskellTypeString    SqlTimeWithZoneT = error "Turbinado ORM Generator: SqlTimeWithZoneT is not supported"
  411
+getHaskellTypeString    SqlBinaryT = "B.ByteString"
  412
+getHaskellTypeString    SqlVarBinaryT = "B.ByteString"
  413
+getHaskellTypeString    SqlLongVarBinaryT = "B.ByteString"
  414
+getHaskellTypeString    t = error "Turbinado ORM Generator: Don't know how to translate this SqlTypeId (" ++ show t ++ " to a Haskell Type"
407 415
 
408 416
 
409 417
 -- | Used for safety.  Lowercases the first letter to 
31  Turbinado/Environment/CodeStore.hs
@@ -9,6 +9,8 @@ import Control.Monad ( when, foldM)
9 9
 import Data.Map hiding (map)
10 10
 import Data.List (isPrefixOf, intersperse)
11 11
 import Data.Maybe
  12
+import Data.Time
  13
+import Data.Time.Clock.POSIX
12 14
 import Data.Typeable
13 15
 import qualified Network.HTTP as HTTP
14 16
 import Prelude hiding (lookup,catch)
@@ -26,6 +28,7 @@ import Turbinado.Environment.Logger
26 28
 import Turbinado.Environment.Types
27 29
 import Turbinado.Environment.Request
28 30
 import Turbinado.Environment.Response
  31
+import Turbinado.Utility.Data
29 32
 import Turbinado.View.Monad hiding (liftIO)
30 33
 import Turbinado.View.XML
31 34
 import Turbinado.Controller.Monad
@@ -33,7 +36,8 @@ import Turbinado.Controller.Monad
33 36
 -- | Create a new store for Code data
34 37
 addCodeStoreToEnvironment :: (HasEnvironment m) => m ()
35 38
 addCodeStoreToEnvironment = do e <- getEnvironment
36  
-                               mv <- liftIO $ newMVar $ empty
  39
+                               let cm = empty
  40
+                               mv <- liftIO $ newMVar cm
37 41
                                setEnvironment $ e {getCodeStore = Just $ CodeStore mv}
38 42
 
39 43
 -- | This function attempts to pull a function from a pre-loaded cache or, if
@@ -41,10 +45,9 @@ addCodeStoreToEnvironment = do e <- getEnvironment
41 45
 retrieveCode :: (HasEnvironment m) => CodeType -> CodeLocation -> m CodeStatus
42 46
 retrieveCode ct cl' = do
43 47
     e <- getEnvironment
44  
-    let (CodeStore mv) = fromJust $ getCodeStore e
  48
+    let (CodeStore mv) = fromJust' "CodeStore: retrieveCode" $ getCodeStore e
45 49
         path  = getDir ct
46  
-    cl <- do -- d <- getCurrentDirectory 
47  
-          return (addExtension (joinPath $ map normalise [path, dropExtension $ fst cl']) "hs", snd cl')
  50
+    cl <- return (addExtension (joinPath $ map normalise [path, dropExtension $ fst cl']) "hs", snd cl')
48 51
     debugM $ "  CodeStore : retrieveCode : loading   " ++ (fst cl) ++ " - " ++ (snd cl)
49 52
     cmap <- liftIO $ takeMVar mv
50 53
     let c= lookup cl cmap
@@ -54,7 +57,7 @@ retrieveCode ct cl' = do
54 57
                Just (CodeLoadFailure _) -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : previous failure; try load") 
55 58
                                               loadCode ct cmap cl
56 59
                _                        -> do debugM ((fst cl) ++ " : " ++ (snd cl) ++ " : checking reload") 
57  
-                                              checkReloadCode ct cmap (fromJust c) cl
  60
+                                              checkReloadCode ct cmap (fromJust' "CodeStore: retrieveCode2" c) cl
58 61
     liftIO $ putMVar mv cmap'
59 62
     -- We _definitely_ have a code entry now, though it may have a MakeFailure
60 63
     let c' = lookup cl cmap'
@@ -92,8 +95,8 @@ checkReloadCode ct cmap cstat cl = do
92 95
         needReloadCode fp fd = do
93 96
             fe <- liftIO $ doesFileExist fp
94 97
             case fe of
95  
-                True -> do mt <- liftIO $ getModificationTime fp    
96  
-                           return $ (True, mt > fd)
  98
+                True -> do TOD mt _ <- liftIO $ getModificationTime fp    
  99
+                           return $ (True, fromIntegral mt > utcTimeToPOSIXSeconds fd)
97 100
                 False-> return (False, True)
98 101
 
99 102
         
@@ -152,7 +155,7 @@ _loadView ct cmap cl args fp = do
152 155
                                       return (insert cl (CodeLoadFailure $ unlines err) cmap)
153 156
                 LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
154 157
                                       liftIO $ unload m
155  
-                                      t <- liftIO $ getClockTime
  158
+                                      t <- liftIO $ getCurrentTime
156 159
                                       case ct of
157 160
                                         CTLayout              -> return (insert cl (CodeLoadView f t) cmap)
158 161
                                         CTView                -> return (insert cl (CodeLoadView f t) cmap)
@@ -170,7 +173,7 @@ _loadController ct cmap cl args fp = do
170 173
                                   return (insert cl (CodeLoadFailure $ unlines err) cmap)
171 174
             LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
172 175
                                   liftIO $ unload m
173  
-                                  t <- liftIO $ getClockTime
  176
+                                  t <- liftIO $ getCurrentTime
174 177
                                   case ct of
175 178
                                     CTController          -> return (insert cl (CodeLoadController f t) cmap)
176 179
                                     CTComponentController -> return (insert cl (CodeLoadComponentController f t) cmap)
@@ -197,9 +200,13 @@ customMergeToDir stb src dir = do
197 200
                 MergeFailure ["Source file does not exist : "++stb]
198 201
         _          -> do
199 202
                 src_str <- liftIO $ readFile src
200  
-                stb_str <- liftIO $ readFile stb
201  
-                let (stbimps, stbdecls) = span ( not . isPrefixOf "-- SPLIT HERE") $ lines stb_str
202  
-                    mrg_str = outTitle ++ (unlines stbimps) ++ src_str ++ (unlines stbdecls)
  203
+                stb_str  <- liftIO $ readFile stb
  204
+                -- Check to see whether the file start with "module ".  If so, the user
  205
+                -- should already have added the require preamble.  Otherwise, merge the stub.
  206
+                let mrg_str = case src_str of
  207
+                                ('m':'o':'d':'u':'l':'e':' ':_) -> src_str
  208
+                                _ -> let (stbimps, stbdecls) = span ( not . isPrefixOf "-- SPLIT HERE") $ lines stb_str
  209
+                                     in outTitle ++ (unlines stbimps) ++ src_str ++ (unlines stbdecls)
203 210
                 liftIO $ createDirectoryIfMissing True outDir
204 211
                 hdl <- liftIO $ openFile outFile WriteMode  -- overwrite!
205 212
                 liftIO $ hPutStr hdl mrg_str 
178  Turbinado/Environment/Cookie.hs 100644 → 100755
... ...
@@ -1,116 +1,108 @@
@@ -121,7 +113,7 @@ readCookies s =
@@ -130,4 +122,14 @@ maybeLast :: [a] -> Maybe a
5  Turbinado/Environment/Database.hs
@@ -10,8 +10,7 @@ import Control.Monad
10 10
 import Control.Monad.State
11 11
 import Control.Monad.Trans
12 12
 import Data.Maybe
13  
-import qualified Database.HDBC as HDBC
14  
-import Database.HDBC (IConnection)
  13
+import Database.HDBC
15 14
 
16 15
 import Config.Master
17 16
 import Turbinado.Controller.Monad
@@ -23,5 +22,5 @@ addDatabaseToEnvironment = do e <- getEnvironment
23 22
                               case databaseConnection of
24 23
                                 Nothing   -> return ()
25 24
                                 Just conn -> do c <- liftIO $ conn 
26  
-                                                setEnvironment $ e {getDatabase = Just c}
  25
+                                                setEnvironment $ e {getDatabase = Just (ConnWrapper c)}
27 26
 
3  Turbinado/Environment/Header.hs
@@ -10,11 +10,12 @@ import Network.HTTP.Headers
10 10
 import Turbinado.Controller.Monad
11 11
 import Turbinado.Environment.Types
12 12
 import Turbinado.Environment.Request
  13
+import Turbinado.Utility.Data
13 14
 
14 15
 -- | Attempts to pull a HTTP header value.
15 16
 getHeader :: (HasEnvironment m) => HeaderName -> m (Maybe String)
16 17
 getHeader h = do e <- getEnvironment
17  
-                 return $ findHeader h (fromJust $ getRequest e)
  18
+                 return $ findHeader h (fromJust' "Header: getHeader" $ getRequest e)
18 19
 
19 20
 -- | Unsafe version of getHeader.  Fails if the key is not found.
20 21
 getHeader_u :: (HasEnvironment m) => HeaderName -> m String
5  Turbinado/Environment/Logger.hs
@@ -11,6 +11,7 @@ import Data.Dynamic
11 11
 import Data.Maybe
12 12
 import System.IO.Unsafe
13 13
 
  14
+import Turbinado.Utility.Data
14 15
 
15 16
 addLoggerToEnvironment :: (HasEnvironment m) => m ()
16 17
 addLoggerToEnvironment = do e <- getEnvironment
@@ -21,11 +22,11 @@ addLoggerToEnvironment = do e <- getEnvironment
21 22
 
22 23
 takeLoggerLock :: (HasEnvironment m) => m ()
23 24
 takeLoggerLock = do e <- getEnvironment
24  
-                    liftIO $ takeMVar (fromJust $ getLoggerLock e)
  25
+                    liftIO $ takeMVar (fromJust' "Logger: takeLoggerLock" $ getLoggerLock e)
25 26
 
26 27
 putLoggerLock  :: (HasEnvironment m) => m ()
27 28
 putLoggerLock =  do e <- getEnvironment
28  
-                    liftIO $ putMVar (fromJust $ getLoggerLock e) ()
  29
+                    liftIO $ putMVar (fromJust' "Logger: putLoggerLock" $ getLoggerLock e) ()
29 30
 
30 31
 wrapLoggerLock :: (HasEnvironment m) => (String -> IO ()) -> String -> m ()
31 32
 wrapLoggerLock lf s = do takeLoggerLock
7  Turbinado/Environment/Params.hs
@@ -11,6 +11,7 @@ import Network.URI
11 11
 import Turbinado.Environment.Header
12 12
 import Turbinado.Environment.Request
13 13
 import Turbinado.Environment.Types
  14
+import Turbinado.Utility.Data
14 15
 
15 16
 -- | Attempt to get a Parameter from the Request query string
16 17
 -- or POST body.
@@ -30,14 +31,14 @@ getParam_u p =  do r <- getParam p
30 31
 -- Functions used by getParam.  Not exported.
31 32
 getParamFromQueryString :: (HasEnvironment m) => String -> m (Maybe String)
32 33
 getParamFromQueryString s = do e <- getEnvironment
33  
-                               let qs = uriQuery $ rqURI (fromJust $ getRequest e)
  34
+                               let qs = uriQuery $ rqURI (fromJust' "Params : getParamFromQueryString" $ getRequest e)
34 35
                                return $ lookup s $ formDecode qs
35 36
 
36 37
 getParamFromBody :: (HasEnvironment m) => String -> m (Maybe String)
37 38
 getParamFromBody s = do e <- getEnvironment
38 39
                         ct <- getHeader HdrContentType
39  
-                        let rm = rqMethod (fromJust $ getRequest e)
40  
-                            rb = rqBody   (fromJust $ getRequest e)
  40
+                        let rm = rqMethod (fromJust' "Params : getParamsFromBody" $ getRequest e)
  41
+                            rb = rqBody   (fromJust' "Params : getParamsFromBody" $ getRequest e)
41 42
                         case rm of
42 43
                           POST -> -- TODO: ADD MULTIPART
43 44
                                   return $ lookup s $ formDecode rb
4  Turbinado/Environment/Response.hs
@@ -16,6 +16,10 @@ import System.Time
16 16
 import System.Locale
17 17
 
18 18
 
  19
+--getResponse :: (HasEnvironment m) => m HTTP.Response
  20
+--getResponse  = do e <- getEnvironment
  21
+--                  return $ getResponse e
  22
+
19 23
 setResponse :: (HasEnvironment m) => HTTP.Response -> m ()
20 24
 setResponse resp = do e <- getEnvironment
21 25
                       setEnvironment $ e {getResponse = Just resp}
42  Turbinado/Environment/Routes.hs 100644 → 100755
@@ -2,27 +2,37 @@ module Turbinado.Environment.Routes (
2 2
     addRoutesToEnvironment,
3 3
     runRoutes
4 4
     ) where
5  
-    
  5
+
  6
+import Control.Concurrent.MVar
6 7
 import Text.Regex
7 8
 import Data.Maybe
8 9
 import Data.Typeable
9 10
 import Data.Dynamic
10 11
 import qualified Data.Map as M
  12
+import Data.Time
11 13
 import Control.Monad
12 14
 import qualified Network.HTTP as HTTP
13 15
 import qualified Network.URI as URI
  16
+import Turbinado.Controller.Monad
14 17
 import Turbinado.Controller.Exception
15 18
 import Turbinado.Environment.Types
16 19
 import Turbinado.Environment.Logger
17 20
 import Turbinado.Environment.Request
18 21
 import Turbinado.Environment.Settings
19 22
 import qualified Turbinado.Environment.Settings as S
  23
+import Turbinado.Utility.Data
20 24
 
21 25
 import qualified Config.Routes
22 26
 
23 27
 addRoutesToEnvironment :: (HasEnvironment m) => m ()
24 28
 addRoutesToEnvironment = do e <- getEnvironment
25  
-                            setEnvironment $ e {getRoutes = Just $ Routes $ parseRoutes Config.Routes.routes}
  29
+                            let CodeStore mv = fromJust' "Turbinado.Environment.Routes.addRoutesToEnvironment : no CodeStore" $ getCodeStore e
  30
+                            cm <- liftIO $ takeMVar mv
  31
+                            let cm'  = addStaticControllers Config.Routes.staticControllers cm
  32
+                                cm'' = addStaticViews (Config.Routes.staticViews ++ Config.Routes.staticLayouts) cm'
  33
+                            liftIO $ putMVar mv cm''
  34
+                            setEnvironment $ e {
  35
+                              getRoutes = Just $ Routes $ parseRoutes Config.Routes.routes}
26 36
 
27 37
 
28 38
 ------------------------------------------------------------------------------
@@ -32,18 +42,19 @@ addRoutesToEnvironment = do e <- getEnvironment
32 42
 runRoutes :: (HasEnvironment m) => m ()
33 43
 runRoutes   = do debugM $ "  Routes.runRoutes : starting"
34 44
                  e <- getEnvironment
35  
-                 let Routes rs = fromJust $ getRoutes e
36  
-                     r         = fromJust $ getRequest e
  45
+                 let Routes rs = fromJust' "Routes : runRoutes : getRoutes" $ getRoutes e
  46
+                     r         = fromJust' "Routes : runRoutes : getRequest" $ getRequest e
37 47
                      p    = URI.uriPath $ HTTP.rqURI r
38  
-                     sets = msum $ map (\(r, k) -> maybe [] (zip k) (matchRegex r p)) rs
  48
+                     sets = filter (not . null) $ map (\(r, k) -> maybe [] (zip k) (matchRegex r p)) rs
39 49
                  case sets of
40  
-                  [] -> throwController $ ParameterLookupFailed $ "No routes matched for " ++ p
41  
-                  _  -> do mapM (\(k, v) -> setSetting k v) sets
  50
+                  [] -> do setSetting "controller" $ last Config.Routes.routes  -- no match, so use the last route
  51
+                           addDefaultAction
  52
+                  _  -> do mapM (\(k, v) -> setSetting k v) $ head sets
42 53
                            addDefaultAction
43 54
 
44 55
 addDefaultAction :: (HasEnvironment m) => m ()
45 56
 addDefaultAction   = do e <- getEnvironment
46  
-                        let s = fromJust $ getSettings e
  57
+                        let s = fromJust' "Routes : addDefaultAction : getSettings" $ getSettings e
47 58
                         setEnvironment $ e {getSettings = Just (M.insertWith (\ a b -> b) "action" (toDyn "Index") s)}
48 59
 
49 60
 ------------------------------------------------------------------------------
@@ -72,3 +83,18 @@ splitOn c l = reverse $ worker c l []
72 83
            worker c (l:ls) (r:rs) = if (l == c) 
73 84
                                       then worker c ls ([]:r:rs)
74 85
                                       else worker c ls ((r++[l]):rs)
  86
+
  87
+
  88
+----------------------------------------------------------------------------
  89
+-- Handle static routes
  90
+----------------------------------------------------------------------------
  91
+
  92
+--addStaticViews :: [(String, String, View XML)] -> CodeMap -> CodeMap
  93
+addStaticViews [] cm = cm
  94
+addStaticViews ((p,f,v):vs) cm = let cm' = M.insert (p,f) (CodeLoadView v $ UTCTime (ModifiedJulianDay 1000000) (secondsToDiffTime 0)) cm in
  95
+                                 addStaticViews vs cm'
  96
+
  97
+addStaticControllers [] cm = cm
  98
+addStaticControllers ((p,f,c):cs) cm = let cm' = M.insert (p,f) (CodeLoadController c $ UTCTime (ModifiedJulianDay 1000000) (secondsToDiffTime 0)) cm in
  99
+                                       addStaticControllers cs cm'
  100
+
132  Turbinado/Environment/Session.hs
... ...
@@ -1,132 +0,0 @@
1  
-module Turbinado.Environment.Session (
2  
-	  Session	-- ^ Abstract
3  
-	-- * Functions used in HSP
4  
-	, getVarValue	-- ^ :: Session -> Key -> (Maybe Value)
5  
-	, setVarValue	-- ^ :: Session -> Key -> Value -> ()
6  
-	, deleteVar	-- ^ :: Session -> Key -> ()
7  
-	, abandon	-- ^ :: Session -> ()
8  
-	, setExpires	-- ^ :: Session -> UTCTime -> ()
9  
-	-- * Functions used by the RTS
10  
-	, isSession	-- ^ :: Session -> Bool
11  
-	, getSessionId  -- ^ :: Session -> (Maybe SessionId)
12  
-	, getExpires	-- ^ :: Session -> Expires
13  
-	, initSession	-- ^ :: [(Key, Value)] -> Session
14  
-	, noSession	-- ^ :: Session
15  
-	, getNewVars	-- ^ :: Session -> [(Key, (Value, Expires))]
16  
-	, getUpdatedVars -- ^ :: Session -> [(Key, (Value, Expires))]
17  
-	, getDeletedVars -- ^ :: Session -> [Key]
18  
-	) where
19  
-
20  
-import qualified Data.Map as M
21  
-import Data.Time
22  
-
23  
--------------------------------------
24  
--- Help types
25  
-
26  
-type Expires = Maybe UTCTime
27  
-type Key = String
28  
-type Value = String
29  
-type SessionId = Int
30  
-
31  
-neverExpire :: Expires
32  
-neverExpire = Nothing
33  
-
34  
-expire :: UTCTime -> Expires
35  
-expire = Just
36  
-
37  
-data Status = New | Orig | Updated | Deleted
38  
-	deriving (Eq)
39  
-
40  
-updateStatus :: Status -> Status
41  
-updateStatus s = case s of
42  
-	New -> New
43  
-	_   -> Updated
44  
-
45  
-----------------------------------------
46  
--- The main datatypes
47  
-
48  
--- | The 'Session' datatype is basically a data repository.
49  
--- To keep tracks of updates, we use an extra repository.
50  
-newtype Session = Session (Maybe SessionData)
51  
-
52  
-data SessionData = SessionData {
53  
-	sessionId :: Maybe SessionId, 
54  
-	expires :: Expires,
55  
-	dataRep :: M.Map Key (Value,Expires,Status)
56  
-	}
57  
-
58  
--- | Create a new 'Session' object with initial data.
59  
-initSession :: SessionId -> Expires -> [(Key, (Value, Expires))] -> Session
60  
-initSession sid exps initData = 
61  
-	let dat = map (\(k,(v,e)) -> (k,(v,e,Orig))) initData 
62  
-            rep = M.fromList dat
63  
-	    sd  = SessionData { 
64  
-			dataRep = rep,
65  
-			expires = exps, 
66  
-			sessionId = Just sid } in
67  
-	 Session (Just sd)
68  
-
69  
-noSession :: Session
70  
-noSession = Session Nothing
71  
-
72  
----------------------------------------
73  
--- Operate on sessions
74  
-
75  
--- | Retrieve the value of a variable in the repository.
76  
-getVarValue :: Session -> Key -> Maybe Value
77  
-getVarValue (Session Nothing) k = Nothing
78  
-getVarValue (Session (Just sd)) k = 
79  
-	case (M.lookup k (dataRep sd)) of
80  
-		Nothing -> Nothing
81  
-		Just (v,e,Deleted) -> Nothing
82  
-		Just (v,e,_) -> Just v
83  
-
84  
-setVarValue :: Session -> Key -> Value -> Session
85  
-setVarValue (Session Nothing) k v = error "Tried to setVarValue without a valid session"
86  
-setVarValue (Session (Just sd)) k v =
87  
-	 case (M.lookup k (dataRep sd)) of
88  
-		Nothing -> Session $ Just $ sd {dataRep = M.insert k (v, neverExpire, New) (dataRep sd)}
89  
-		Just (_,e,st) -> Session $ Just $ sd {dataRep = M.insert k (v, e, updateStatus st) (dataRep sd)}
90  
-		
91  
-deleteVar :: Session -> Key -> Session
92  
-deleteVar (Session Nothing) k = (Session Nothing)
93  
-deleteVar (Session (Just sd)) k = Session $ Just $ sd {dataRep = M.delete k (dataRep sd)}
94  
-
95  
-abandon :: Session -> Session
96  
-abandon (Session mvs) = (Session Nothing)
97  
-
98  
-setExpires :: Session -> UTCTime -> Session
99  
-setExpires (Session Nothing) ct = error "Tried to setVarValue without a valid session"
100  
-setExpires (Session (Just sd)) ct = Session $ Just $ sd {expires = expire ct} 
101  
-
102  
------------------------------------------
103  
--- Used by HSPR
104  
-
105  
-isSession :: Session -> Bool
106  
-isSession (Session Nothing) = False
107  
-isSession _         = True
108  
-
109  
-
110  
-getSessionId :: Session -> Maybe SessionId
111  
-getSessionId (Session Nothing) = Nothing
112  
-getSessionId (Session (Just sd)) = sessionId sd
113  
-
114  
-getExpires :: Session -> Expires
115  
-getExpires (Session Nothing) = Nothing
116  
-getExpires (Session (Just sd)) = expires sd
117  
-
118  
-
119  
-getVars :: Status -> Session -> [(Key, (Value, Expires))]
120  
-getVars status (Session Nothing) = []
121  
-getVars status (Session (Just sd)) = 
122  
-  let vals    = M.toList (dataRep sd)
123  
-      newVals = filter (\(_,(_,_,st)) -> st == status) vals
124  
-  in map (\(k,(v,e,_)) -> (k,(v,e))) newVals
125  
-
126  
-getNewVars, getUpdatedVars :: Session -> [(Key, (Value, Expires))]
127  
-getNewVars = getVars New
128  
-getUpdatedVars = getVars Updated
129  
-
130  
-getDeletedVars :: Session -> [Key]
131  
-getDeletedVars (Session Nothing) = []
132  
-getDeletedVars s = map fst $ getVars Deleted s
161  Turbinado/Environment/Session/CookieSession.hs
... ...
@@ -0,0 +1,161 @@
  1
+-----------------------------------------------------------------------------
  2
+-- |
  3
+-- Module      :  Turbinado.Environment.Session.CookieSession
  4
+-- Copyright   :  (c) Niklas Broberg 2004, Michael Snoyman 2008-2009, Alson Kemp 2009
  5
+-- License     :  BSD-style (see the file LICENSE)
  6
+-- 
  7
+-- Maintainer  :  Alson Kemp, alson@alsonkemp.com
  8
+-- Stability   :  experimental
  9
+-- Portability :  requires undecidable and overlapping instances
  10
+--
  11
+-- Much of this code is lifted/derived from Niklas' HSP and from Michael's HWeb.
  12
+-----------------------------------------------------------------------------
  13
+module Turbinado.Environment.Session.CookieSession where
  14
+
  15
+import Control.Monad.Trans
  16
+import Data.List
  17
+import Data.Maybe
  18
+import qualified Data.Map as M
  19
+import Data.Time
  20
+import System.IO
  21
+
  22
+import qualified Data.Digest.MD5 as MD5
  23
+import Data.LargeWord (Word128)
  24
+import Data.Word (Word8)
  25
+import Codec.Encryption.Modes
  26
+import qualified Codec.Encryption.AES as AES
  27
+import qualified Codec.Binary.Base64 as Base64
  28
+import Codec.Utils
  29
+import qualified Network.HTTP.Headers as Headers
  30
+import Turbinado.Environment.Cookie
  31
+import Turbinado.Environment.Types
  32
+import Turbinado.Utility.Data
  33
+
  34
+type Key = String
  35
+type Value = String
  36
+
  37
+
  38
+instance (HasEnvironment m) => HasSession m where
  39
+  newSession opts = let n = maybe
  40
+                              (error "'cookie-name' didn't exist in options passed to newSession")
  41
+                              id
  42
+                              (lookup "cookie-name" opts)
  43
+                    in _setSession $ emptySession { sessionName = Just n }
  44
+  hasValidSession = do e <- getEnvironment
  45
+                       case getSession e of
  46
+                        Nothing -> return False
  47
+                        Just s -> case expires s of
  48
+                                    Nothing -> return True
  49
+                                    Just t  -> do now <- liftIO $ getCurrentTime
  50
+                                                  return $ t > now
  51
+  retrieveSession opts = do let c = maybe
  52
+                                     (error "'cipher-key' didn't exist in options passed to retrieveSession")
  53
+                                     id
  54
+                                     (lookup "cipher-key" opts)
  55
+                                n = maybe
  56
+                                     (error "'cookie-name' didn't exist in options passed to retrieveSession")
  57
+                                     id
  58
+                                     (lookup "cookie-name" opts)
  59
+                            message'' <- getCookie n
  60
+                            e <- getEnvironment
  61
+                            case message'' of
  62
+                              Nothing  -> newSession opts
  63
+                              Just m'' -> let message' = maybeRead m'' in
  64
+                                          case message' of
  65
+                                            Nothing     -> newSession opts
  66
+                                            Just (m, h) -> do let messageBlocks = unCbc AES.decrypt 0 (w8ToKey $ MD5.hash $ stringToW8 c) (w8ToBlocks $ fromJust' "CookieSession : retrieveSession" $ Base64.decode m)
  67
+                                                                  hashCode = fromJust' "CookieSession : retreiveSession(2)" $ Base64.decode h
  68
+                                                                  hashCheck = MD5.hash $ blocksToW8 messageBlocks
  69
+                                                              if (hashCode == hashCheck)
  70
+                                                                then let s = read (w8ToString $ blocksToW8 messageBlocks) in
  71
+                                                                     case (expires s) of
  72
+                                                                       Nothing -> do _setSession s
  73
+                                                                       Just t -> do t' <- liftIO $ getCurrentTime
  74
+                                                                                    if (t > t')
  75
+                                                                                     then _setSession s
  76
+                                                                                     else newSession opts
  77
+                                                                else newSession opts
  78
+  persistSession opts  = do e <- getEnvironment
  79
+                            let s' = getSession e
  80
+                            case s' of
  81
+                              Nothing -> return ()
  82
+                              Just s -> do let c = maybe
  83
+                                                    (error "'cipher-key' didn't exist in options passed to persistSession")
  84
+                                                    id
  85
+                                                    (lookup "cipher-key" opts)
  86
+                                               ex = maybe
  87
+                                                      Nothing
  88
+                                                      maybeReadUTC
  89
+                                                      (lookup "session-expires" opts)
  90
+                                               message = stringToW8 $ show s
  91
+                                               cipheredMessage = Base64.encode $ blocksToW8 $ cbc AES.encrypt 0 (w8ToKey $ MD5.hash $ stringToW8 c) (w8ToBlocks message)
  92
+                                               hashCode = Base64.encode $ MD5.hash message
  93
+                                           setCookie 
  94
+                                             (Cookie {cookieName = fromJust' "CookieSession : persistSession" $ sessionName s
  95
+                                                     ,cookieValue = (show $ (cipheredMessage, hashCode))
  96
+                                                     ,cookieExpires = ex
  97
+                                                     ,cookieDomain = Nothing
  98
+                                                     ,cookiePath = Nothing
  99
+                                                     }
  100
+                                             )
  101
+  abandonSession = do e <- getEnvironment
  102
+                      let s = getSession e
  103
+                      setEnvironment $ e {getSession = Nothing}
  104
+                      case s of
  105
+                        Nothing -> return ()
  106
+                        Just s' -> deleteCookie (fromJust' "CookieSession : abandonSession" $ sessionName s')
  107
+  getSessionValue k = do s <- _getSession
  108
+                         return $ M.lookup k $ dataRep s
  109
+  setSessionValue k v = do s <- _getSession
  110
+                           let s' = s {dataRep = M.insert k v (dataRep s)}
  111
+                           _setSession s'
  112
+  deleteSessionKey k = do s <- _getSession
  113
+                          let s' = s {dataRep = M.delete k (dataRep s)}
  114
+                          _setSession s'
  115
+  getSessionExpires = (return . expires) =<< _getSession
  116
+  setSessionExpires ct = do s <- _getSession
  117
+                            let s' = s {expires = ct}
  118
+                            _setSession s'
  119
+  setSessionId sid = do s <- _getSession
  120
+                        let s' = s {sessionId = sid}
  121
+                        _setSession s'
  122
+  getSessionId  = (return . sessionId) =<< _getSession
  123
+
  124
+
  125
+--
  126
+-- * Helpers 
  127
+--
  128
+stringToW8 :: String -> [Word8]
  129
+stringToW8 = map (fromInteger . toInteger . fromEnum)
  130
+
  131
+w128ToW8 :: Word128 -> [Word8]
  132
+w128ToW8 w128 = toOctets 256 w128
  133
+
  134
+w8ToString :: [Word8] -> String
  135
+w8ToString = map (toEnum . fromInteger . toInteger)
  136
+
  137
+blocksToString :: [[Word8]] -> String
  138
+blocksToString ws = concat $ map w8ToString ws
  139
+
  140
+blocksToW8 :: [Word128] -> [Word8]
  141
+blocksToW8 ws = concat $ map w128ToW8 ws
  142
+
  143
+w8ToKey :: [Word8] ->  Word128
  144
+w8ToKey ws = fromInteger $ foldl (\acc i -> acc*256 + toInteger i) (0::Integer) ws
  145
+