Merge branch 'master' of git://github.com/norm2782/JCU

Conflicts:
	src/Application.hs
	src/JCU/Templates.hs

JCU.cabal

@@ -54,6 +54,7 @@ Executable jcu
     MonadCatchIO-transformers >= 0.2.1 && < 0.3,
     mtl >= 2.0,
     NanoProlog >= 0.3,
+    resource-pool-catchio >= 0.2 && < 0.3,
     snap >= 0.6,
     snap-core >= 0.6,
     snap-server >= 0.6,

packaging/initPgSqlDb.sql

@@ -12,14 +12,14 @@ SET client_min_messages = warning;
 -- Name: plpgsql; Type: EXTENSION; Schema: -; Owner: 
 --
 
-CREATE EXTENSION IF NOT EXISTS plpgsql WITH SCHEMA pg_catalog;
+-- CREATE EXTENSION IF NOT EXISTS plpgsql WITH SCHEMA pg_catalog;
 
 
 --
 -- Name: EXTENSION plpgsql; Type: COMMENT; Schema: -; Owner: 
 --
 
-COMMENT ON EXTENSION plpgsql IS 'PL/pgSQL procedural language';
+-- COMMENT ON EXTENSION plpgsql IS 'PL/pgSQL procedural language';
 
 
 SET search_path = public, pg_catalog;

src/Application.hs

@@ -22,10 +22,12 @@ import            Data.ListLike (CharString(..))
 import            Data.Map (Map)
 import qualified  Data.Map as DM
 import            Data.Maybe
+import            Data.Pool
 import            Data.String
 import            Data.Text (Text)
 import qualified  Data.Text as DT
 import qualified  Data.Text.Encoding as DT
+import qualified  Database.HDBC as HDBC
 import            Database.HDBC.PostgreSQL
 import            JCU.Prolog
 import            JCU.Templates
@@ -48,24 +50,20 @@ import            Text.Digestive
 import            Text.Digestive.Blaze.Html5
 import            Text.Digestive.Forms.Snap
 import qualified  Text.Email.Validate as E
-import qualified  Database.HDBC as HDBC
 
 
 data App = App
   {  _authLens  :: Snaplet (AuthManager App)
   ,  _sessLens  :: Snaplet SessionManager
-  ,  _dbLens    :: Snaplet (HdbcSnaplet Connection IO)
+  ,  _dbLens    :: Snaplet (HdbcSnaplet Connection Pool)
   }
 
 makeLens ''App
 
 type AppHandler = Handler App App
 
-instance HasHdbc (Handler b App) Connection IO where
+instance HasHdbc (Handler b App) Connection Pool where
   getHdbcState = with dbLens get
-
--- instance Control.Monad.Trans.Control.MonadBaseControl IO (Handler b App) where
-
 
 jcu :: SnapletInit App App
 jcu = makeSnaplet "jcu" "Prolog proof tree practice application" Nothing $ do
@@ -86,12 +84,11 @@ jcu = makeSnaplet "jcu" "Prolog proof tree practice application" Nothing $ do
              ]
   _sesslens'  <- nestSnaplet "session" sessLens $ initCookieSessionManager
                    "config/site_key.txt" "_session" Nothing
-  let sqli = do connString <- readFile "config/connection_string.conf"
-                c <- connectPostgreSQL connString
-                return c
-  _dblens'    <- nestSnaplet "hdbc" dbLens $ hdbcInit sqli
+  let pgsql = connectPostgreSQL' =<< readFile "config/connection_string.conf"
+  pool <- liftIO $ createPool pgsql HDBC.disconnect 1 500 1
+  _dblens'    <- nestSnaplet "hdbc" dbLens $ hdbcInit pool
   _authlens'  <- nestSnaplet "auth" authLens $ initHdbcAuthManager
-                   defAuthSettings sessLens sqli defAuthTable defQueries
+                   defAuthSettings sessLens pool defAuthTable defQueries
   return  $ App _authlens' _sesslens' _dblens'
 
 
@@ -182,7 +179,9 @@ deleteStoredRuleH = restrict forbiddenH $ do
   mrid <- getParam "id"
   case mrid of
     Nothing  -> return ()
-    Just x   -> deleteRule x -- TODO: Take user ID into account. we don't want people deleting other users's rules
+    Just x   -> do
+      uid <- getUserId
+      deleteRule uid x
 
 addStoredRuleH :: AppHandler ()
 addStoredRuleH = restrict forbiddenH $ do
@@ -196,15 +195,14 @@ addStoredRuleH = restrict forbiddenH $ do
         (Just newID) -> do modifyResponse $ setContentType "application/json"
                            writeLBS $ encode (AddRes newID)
         Nothing      -> error500H undefined
-        
+
 
 loadExampleH :: AppHandler ()
 loadExampleH = restrict forbiddenH $ do
   uid <- getUserId
   deleteUserRules uid
   mapM_ (insertRule uid) exampleData
-  -- commitSession
-  -- redirect "/"
+  redirect "/"
 
 
 getUserId :: AppHandler UserId
@@ -346,42 +344,32 @@ registrationForm = (\ep pp _ -> FormUser (fst ep) (fst pp) False)
 -------------------------------------------------------------------------------
 -- Database interaction
 
-voidM :: Monad m => m a -> m ()
-voidM m = do
-  _ <- m
-  return ()
-
--- TODO: This is just a workaround....
-q :: HasHdbc m c s => String -> [SqlValue] -> m ()
-q qry vals = withTransaction $ \conn' -> do
-               stmt  <- HDBC.prepare conn' qry
-               _     <- HDBC.execute stmt vals
-               return ()
-
-insertRule :: HasHdbc m c s => UserId -> Rule -> m (Maybe Int)
-insertRule uid rl = let sqlVals = [toSql $ unUid uid, toSql $ show rl] in do
-  q  "INSERT INTO rules (uid, rule_order, rule) VALUES (?, 1, ?)" sqlVals
-  rws <- query  "SELECT rid FROM rules WHERE uid = ? AND rule = ? ORDER BY rid DESC"
-                sqlVals
-  return $ case rws of
-             []     -> Nothing
-             (x:_)  -> Just $ fromSql $ x DM.! "rid"
-
-deleteRule :: HasHdbc m c s => ByteString -> m ()
-deleteRule rid = q "DELETE FROM rules WHERE rid = ?" [toSql rid]
+insertRule :: (Functor m, HasHdbc m c s) => UserId -> Rule -> m (Maybe Int)
+insertRule uid rl =
+  let sqlVals = [toSql $ unUid uid, toSql $ show rl]
+  in do
+    void $ query' "INSERT INTO rules (uid, rule_order, rule) VALUES (?, 1, ?)" sqlVals
+    rws <- query "SELECT rid FROM rules WHERE uid = ? AND rule = ? ORDER BY rid DESC" sqlVals
+    return $ case rws of
+               []     -> Nothing
+               (x:_)  -> Just $ fromSql $ x DM.! "rid"
+
+deleteRule :: (Functor m, HasHdbc m c s) => UserId -> ByteString -> m ()
+deleteRule uid rid = void $ query'
+  "DELETE FROM rules WHERE rid = ? AND uid = ?" [toSql rid, toSql uid]
 
 getStoredRules :: HasHdbc m c s => UserId -> m [DBRule]
 getStoredRules uid = do
-  rs <- query  "SELECT rid, rule_order, rule FROM rules WHERE uid = ?"
-               [toSql uid]
-  return $ map convRow rs
-  where  convRow :: Map String SqlValue -> DBRule
+  rws <- query "SELECT rid, rule_order, rule FROM rules WHERE uid = ?" [toSql uid]
+  return $ map convRow rws
+  where  convRow :: Map String HDBC.SqlValue -> DBRule
          convRow mp =
            let  rdSql k = fromSql $ mp DM.! k
            in   DBRule  (rdSql "rid")
                         (rdSql "rule_order")
                         (fst . startParse pRule $ CS (rdSql "rule"))
 
-deleteUserRules :: HasHdbc m c s => UserId -> m ()
-deleteUserRules uid = q "DELETE FROM rules WHERE uid = ?" [toSql uid]
+deleteUserRules :: (Functor m, HasHdbc m c s) => UserId -> m ()
+deleteUserRules uid = void $ query'
+  "DELETE FROM rules WHERE uid = ?" [toSql uid]