Merge branch 'master' of github.com:spockz/JCU

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;

resources/static/hjs/jcu.hs

@@ -46,9 +46,22 @@ import Array
 import Templates
 import Models
 
+
+----
+--   Constants
+---- 
+
+ruleTreeId     = "ul#proof-tree-view.tree"
+storeDoCheckId = "#storeDoChecking"
+
+----
+--   Helpers
+----
 showError = alert
 showInfo  = alert
 
+-- | Wrapper function for making Ajax Requests with all types set to JSON as it
+--   is the only type of request we will be making.
 ajaxQ :: (JS r, JS v) => AjaxRequestType -> String -> v -> AjaxCallback r -> AjaxCallback r -> IO ()
 ajaxQ rt url =
   AQ.ajaxQ "jcu_app"
@@ -58,31 +71,39 @@ ajaxQ rt url =
                          ao_dataType    = "json"
                        }
 
-registerEvents :: [(String, JEventType, EventHandler)] -> IO ()
-registerEvents = mapM_ (\ (e, event, eh) -> do elem <- jQuery e
-                                               unbind elem event
-                                               bind elem event eh)
+-- | Update an existing input field that is used to store `global' variables
+--   Not entirely best practice. This should perhaps be modelled in a State
+--   monad.
+updateStore :: (Read a, Show a) => Selector -> (a -> a) -> IO ()
+updateStore sel updateF = do
+  store <- jQuery sel
+  val   <- fmap read (valString store)
+  setValString store (show $ updateF val)
+
+-- | Read the contents of the store
+readStore :: (Read a) => Selector -> IO a
+readStore sel = fmap read (jQuery storeDoCheckId >>= valString)
 
+----
+--   Application
+----
 main :: IO ()
 main = do init <- wrapIO initialize
           onDocumentReady init
 
-ruleTreeId = "ul#proof-tree-view.tree"
-storeDoCheckId = "#storeDoChecking"
+
 
 initialize :: IO ()
 initialize = do -- Rendering
                 bd <- jQuery "#bd"
                 setHTML bd Templates.home
                 wrapInner bd "<div id=\"home-view\"/>"
                 -- Proof tree
-
+                addRuleTree
                 -- Rules list
                 obj <- mkAnonObj
                 ajaxQ GET "/rules/stored" obj addRules noop
 
-                addRuleTree
-
                 registerEvents [("#btnCheck"  , Click    , toggleClue emptyProof)
                                ,("#btnAddRule", Click    , addRuleEvent)
                                ,("#btnReset"  , Click    , resetTree)
@@ -97,17 +118,20 @@ initialize = do -- Rendering
                                  Nothing -> markInvalidTerm inp
                                  _       -> return ()
                                return True
-        resetTree _ = do replaceRuleTree emptyProof
+        resetTree _ = do -- Do not forget to add the class that hides the colours
+                         jQuery "#proof-tree-div" >>= flip addClass "noClue"
+                         -- Always store False in the store.
+                         updateStore storeDoCheckId (const False)
+                         replaceRuleTree emptyProof
                          return True
 
+-- Toggles checking of the proof and showing the results
 toggleClue :: Proof -> EventHandler
 toggleClue p _ = do toggleClassString "#proof-tree-div" "noClue"
-                    store <- jQuery storeDoCheckId
-                    val   <- fmap (read :: String -> Bool) (valString store)
-                    setValString store (show $ not val)
+                    updateStore storeDoCheckId not
                     replaceRuleTree p
                     return True                
-                                               
+
 
 emptyProof :: Proof
 emptyProof = T.Node (Var "") []
@@ -118,7 +142,8 @@ addRuleTree = do
   ruleTreeDiv <- jQuery "#proof-tree-div"
   ruleTreeUL  <- buildRuleUl emptyProof status
   append ruleTreeDiv ruleTreeUL
-
+
+-- | Builds up the rule tree  
 buildRuleUl :: Proof -> PCheck -> IO JQuery
 buildRuleUl node status =
   do topUL <- jQuery "<ul id=\"proof-tree-view\" class=\"tree\"/>"
@@ -134,8 +159,8 @@ buildRuleUl node status =
     f lvl wp (jq, n) (node,status) = do li' <- build' (lvl ++ [n]) wp (node,status) True
                                         append jq li'
                                         return (jq, n + 1)
-    dropje :: Proof -> [Int] -> Proof -> UIThisEventHandler
-    dropje wp lvl node this _ ui = do
+    onDrop :: Proof -> [Int] -> Proof -> UIThisEventHandler
+    onDrop wp lvl node this _ ui = do
       elemVal <- findSelector this "input[type='text']:first" >>= valString
 
       jsRuleText <- (getAttr "draggable" ui >>= getAttr "context" >>= getAttr "innerText") :: IO JSString
@@ -159,9 +184,9 @@ buildRuleUl node status =
 
          dropzones <- findSelector li ".dropzone"
 
-         drop'   <- mkJUIThisEventHandler (dropje wp lvl n) 
-         drop''  <- wrappedJQueryUIEvent drop'
-         droppable dropzones $ Droppable (toJS "dropHover") drop''
+         drop      <- mkJUIThisEventHandler (onDrop wp lvl n) 
+                        >>= wrappedJQueryUIEvent
+         droppable dropzones $ Droppable (toJS "dropHover") drop
          startUl <- jQuery "<ul/>"
          (res,_) <- foldM (f lvl wp) (startUl, 1) (zip childTerms childStatus)
          append li res
@@ -220,7 +245,7 @@ addRuleEvent event = do
 
   case tryParseRule (fromJS rule) of
     Nothing   -> showError "Invalid rule, not adding to rule list."
-    (Just _)  -> do let str = JSString.concat (toJS "{\"rule\":\"") $ JSString.concat rule (toJS "\"}")
+    (Just _)  -> do let str = foldl1 JSString.concat [toJS "{\"rule\":\"", rule, toJS "\"}"]
                     ajaxQ POST "/rules/stored" str (onSuccess (fromJS rule)) onFail
   return True
   where onSuccess :: String -> AjaxCallback Int
@@ -235,17 +260,22 @@ createRuleLi rule id = do item <- jQuery $ "<li>" ++ rules_list_item rule ++ "</
                           click delButton (deleteRule item id)
                           return item
 
+-- | Checks the current proof against the current list of rules. If the user
+--   added rules in a different window or deleted them there those changes will
+--   not be visible here.
 checkProof :: Proof -> IO PCheck
 checkProof p = do rules  <- jQuery ".rule-list-item" >>= jQueryToArray
                   rules' <- (mapM f . elems . jsArrayToArray) rules
-                  doCheck <- fmap (read :: String -> Bool) (jQuery storeDoCheckId >>= valString)
+                  doCheck <- readStore storeDoCheckId
                   if doCheck then
                       return $ Prolog.checkProof rules' p
                     else
                       return $ Prolog.dummyProof p
   where f x =    getAttr "innerText" x 
             >>=  return . fromJust . tryParseRule . (fromJS :: JSString -> String)
-
+
+
+-- | This is how I think checkProof should look when using workers.                          
 -- checkProof :: Proof -> (PCheck -> IO ()) -> IO ()
 -- checkProof p cps = do rules  <- jQuery ".rule-list-item" >>= jQueryToArray
 --                       rules' <- (mapM f . elems . jsArrayToArray) rules
@@ -285,7 +315,8 @@ markInvalidTerm jq = do clearClasses jq
                         addClass jq "blueField"
 
 deleteRule :: JQuery -> Int -> EventHandler
-deleteRule jq i _ = do ajaxQ DELETE ("/rules/stored/"++show i) i removeLi noop
-                       return False
+deleteRule jq i _ = do 
+  ajaxQ DELETE ("/rules/stored/"++show i) i removeLi noop
+  return False
   where removeLi :: AjaxCallback ()
         removeLi _ _ _ = remove jq

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]