Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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

  • Loading branch information...
commit b8745509972ed73cb035f0a87c99966e531d2350 2 parents d22e542 + bb146b0
@spockz spockz authored
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
4 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;
View
81 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,17 +71,27 @@ 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
@@ -76,13 +99,11 @@ initialize = do -- Rendering
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
View
76 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]
Please sign in to comment.
Something went wrong with that request. Please try again.