Skip to content
Browse files

Merge branch 'pgsql'

Conflicts:
	JCU.cabal
	src/Application.hs
  • Loading branch information...
2 parents 6426fd0 + fac9a7a commit c54f6dec7ce4a2880361f46c744dd5481ffdea9e @norm2782 norm2782 committed Jan 3, 2012
Showing with 65 additions and 43 deletions.
  1. +1 −0 JCU.cabal
  2. +64 −43 src/Application.hs
View
1 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,
View
107 src/Application.hs
@@ -22,11 +22,13 @@ 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 Database.HDBC.PostgreSQL
+import qualified Database.HDBC as HDBC
+import Database.HDBC.MySQL
import JCU.Prolog
import JCU.Templates
import JCU.Types
@@ -37,7 +39,7 @@ import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.Auth
import Snap.Snaplet.Auth.Backends.Hdbc
-import Snap.Snaplet.Hdbc
+{-import Snap.Snaplet.Hdbc-}
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Backends.CookieSession
import Snap.Util.FileServe
@@ -54,18 +56,15 @@ import qualified Database.HDBC as HDBC
data App = App
{ _authLens :: Snaplet (AuthManager App)
, _sessLens :: Snaplet SessionManager
- , _dbLens :: Snaplet (HdbcSnaplet Connection IO)
+ , pgconn :: Connection
}
makeLens ''App
type AppHandler = Handler App App
-instance HasHdbc (Handler b App) Connection IO where
- getHdbcState = with dbLens get
-
--- instance Control.Monad.Trans.Control.MonadBaseControl IO (Handler b App) where
-
+{-instance HasHdbc (Handler b App) Connection IO where-}
+ {-getHdbcState = with dbLens get-}
jcu :: SnapletInit App App
jcu = makeSnaplet "jcu" "Prolog proof tree practice application" Nothing $ do
@@ -86,13 +85,17 @@ 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
+ pass <- readFile "config/connection_string.conf"
+ let pgsql = connectMySql defaultMySQLConnectInfo {
+ mysqlPassword = pass,
+ mysqlDatabase = "jcu"
+ } -- connectPostgreSQL' =<< readFile "config/connection_string.conf"
+ pg <- liftIO $ pgsql
+ -- pool <- liftIO $ createPool pgsql HDBC.disconnect 1 500 1
+ {-_dblens' <- nestSnaplet "hdbc" dbLens $ hdbcInit pgsql-}
_authlens' <- nestSnaplet "auth" authLens $ initHdbcAuthManager
- defAuthSettings sessLens sqli defAuthTable defQueries
- return $ App _authlens' _sesslens' _dblens'
+ defAuthSettings sessLens pgsql defAuthTable defQueries
+ return $ App _authlens' _sesslens' pg
------------------------------------------------------------------------------
@@ -182,7 +185,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
@@ -198,8 +203,7 @@ loadExampleH = restrict forbiddenH $ do
uid <- getUserId
deleteUserRules uid
mapM_ (insertRule uid) exampleData
- -- commitSession
- -- redirect "/"
+ redirect "/"
getUserId :: AppHandler UserId
@@ -347,36 +351,53 @@ voidM m = do
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]
-
-getStoredRules :: HasHdbc m c s => UserId -> m [DBRule]
+q :: String -> [HDBC.SqlValue] -> AppHandler ()
+q qry vals = do
+ c <- gets pgconn
+ c' <- liftIO $ HDBC.clone c
+ liftIO $ HDBC.withTransaction c' $ \conn' -> do
+ stmt <- HDBC.prepare conn' qry
+ voidM $ HDBC.execute stmt vals
+ HDBC.commit c'
+ return ()
+
+insertRule :: UserId -> Rule -> AppHandler (Maybe Int)
+insertRule uid rl =
+ let sqlVals = [HDBC.toSql $ unUid uid, HDBC.toSql $ show rl]
+ in do
+ q "INSERT INTO rules (uid, rule_order, rule) VALUES (?, 1, ?)" sqlVals
+ c <- gets pgconn
+ c' <- liftIO $ HDBC.clone c
+ rws <- liftIO $ do
+ stmt <- HDBC.prepare c' "SELECT rid FROM rules WHERE uid = ? AND rule = ? ORDER BY rid DESC"
+ voidM $ HDBC.execute stmt sqlVals
+ HDBC.fetchAllRowsMap' stmt
+ return $ case rws of
+ [] -> Nothing
+ (x:_) -> Just $ HDBC.fromSql $ x DM.! "rid"
+
+deleteRule :: UserId -> ByteString -> AppHandler ()
+deleteRule uid rid = q "DELETE FROM rules WHERE rid = ? AND uid = ?"
+ [HDBC.toSql rid, HDBC.toSql uid]
+
+getStoredRules :: UserId -> AppHandler [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
+ c <- gets pgconn
+ c' <- liftIO $ HDBC.clone c
+ rws <- liftIO $ do
+ stmt <- HDBC.prepare c' "SELECT rid, rule_order, rule FROM rules WHERE uid = ?"
+ voidM $ HDBC.execute stmt [HDBC.toSql uid]
+ HDBC.fetchAllRowsMap' stmt
+ {-rs <- 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
+ let rdSql k = HDBC.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 :: UserId -> AppHandler ()
+deleteUserRules uid = q "DELETE FROM rules WHERE uid = ?" [HDBC.toSql uid]

0 comments on commit c54f6de

Please sign in to comment.
Something went wrong with that request. Please try again.