Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 376 lines (326 sloc) 12.775 kb
b6aac5b Use OverloadedStrinsg
3555003 authored
1 {-# LANGUAGE OverloadedStrings #-}
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
2 {-# LANGUAGE TemplateHaskell #-}
2a7365b Separate code and put in separate namespace
3555003 authored
3 {-# LANGUAGE MultiParamTypeClasses #-}
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
4 {-# LANGUAGE FlexibleInstances #-}
2a7365b Separate code and put in separate namespace
3555003 authored
5 {-# LANGUAGE TypeSynonymInstances #-}
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
6 {-# LANGUAGE FlexibleContexts #-}
2a7365b Separate code and put in separate namespace
3555003 authored
7
ca6cb7d Snap init
3555003 authored
8
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
9 module Application where
ca6cb7d Snap init
3555003 authored
10
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
11 import Control.Applicative
653ff73 @norm2782 Handle DuplicateUser exception on registration
norm2782 authored
12 import Control.Exception (SomeException)
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
13 import Control.Monad
653ff73 @norm2782 Handle DuplicateUser exception on registration
norm2782 authored
14 import Control.Monad.CatchIO hiding (Handler)
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
15 import Control.Monad.Reader
16 import Control.Monad.State
17 import Data.Aeson as AE
c62f56b @norm2782 Clean up a bit and get rid of some undefineds
norm2782 authored
18 import Data.ByteString.Char8 (ByteString)
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
19 import qualified Data.ByteString.Char8 as BS
20 import Data.Lens.Template
7724fd6 @norm2782 Use ListLike CS and CSL to forego unpacking of ByteStrings
norm2782 authored
21 import Data.ListLike (CharString(..))
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
22 import Data.Map (Map)
23 import qualified Data.Map as DM
24 import Data.Maybe
783ea23 Resource-pool
Jurriën Stutterheim authored
25 import Data.Pool
bee243c @norm2782 Use fromString instead of explicit packs
norm2782 authored
26 import Data.String
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
27 import Data.Text (Text)
28 import qualified Data.Text as DT
29 import qualified Data.Text.Encoding as DT
e918acd In progress
Jurriën Stutterheim authored
30 import qualified Database.HDBC as HDBC
9a21578 @spockz * File for connectionstring
authored
31 import Database.HDBC.PostgreSQL
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
32 import JCU.Prolog
33 import JCU.Templates
34 import JCU.Types
35 import Language.Prolog.NanoProlog.NanoProlog
9f53fa2 @norm2782 Port to NanoProlog 0.3
norm2782 authored
36 import Language.Prolog.NanoProlog.Parser
653ff73 @norm2782 Handle DuplicateUser exception on registration
norm2782 authored
37 import Prelude hiding (catch)
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
38 import Snap.Core
39 import Snap.Snaplet
40 import Snap.Snaplet.Auth
41 import Snap.Snaplet.Auth.Backends.Hdbc
42 import Snap.Snaplet.Hdbc
43 import Snap.Snaplet.Session
44 import Snap.Snaplet.Session.Backends.CookieSession
45 import Snap.Util.FileServe
46 import Text.Blaze
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
47 import qualified Text.Blaze.Html5 as H
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
48 import Text.Blaze.Renderer.Utf8 (renderHtml)
49 import Text.Digestive
50 import Text.Digestive.Blaze.Html5
51 import Text.Digestive.Forms.Snap
52 import qualified Text.Email.Validate as E
ca6cb7d Snap init
3555003 authored
53
fd8d56b @spockz Nu met alert type om te checken of het wel echt een string is. En ja dus...
authored
54
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
55 data App = App
56 { _authLens :: Snaplet (AuthManager App)
57 , _sessLens :: Snaplet SessionManager
291b5f3 @norm2782 Proper PostgreSQL and resource-pool-catchio implementation
norm2782 authored
58 , _dbLens :: Snaplet (HdbcSnaplet Connection Pool)
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
59 }
60
61 makeLens ''App
62
63 type AppHandler = Handler App App
64
291b5f3 @norm2782 Proper PostgreSQL and resource-pool-catchio implementation
norm2782 authored
65 instance HasHdbc (Handler b App) Connection Pool where
5c37d31 @spockz * Works with snap 0.7
authored
66 getHdbcState = with dbLens get
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
67
68 jcu :: SnapletInit App App
69 jcu = makeSnaplet "jcu" "Prolog proof tree practice application" Nothing $ do
38e8cdf @norm2782 README.md in cabal file
norm2782 authored
70 addRoutes [ ("/", ifTop siteIndexH)
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
71 , ("/forbidden", forbiddenH)
72 , ("/login", loginH)
73 , ("/logout", logoutH)
74 , ("/signup", signupH)
75 , ("/rules/stored", method GET readStoredRulesH)
76 , ("/rules/stored", method POST addStoredRuleH)
77 , ("/rules/stored/:id", method DELETE deleteStoredRuleH)
78 , ("/proof/check", method POST checkProofH)
79 , ("/rules/unify", method POST unifyH)
80 , ("/load-example", method GET loadExampleH)
81 , ("/check-syntax/:type", method POST checkSyntaxH)
82 , ("/subst/:sub/:for", method POST substH)
83 , ("", serveDirectory "resources/static")
84 ]
85 _sesslens' <- nestSnaplet "session" sessLens $ initCookieSessionManager
86 "config/site_key.txt" "_session" Nothing
291b5f3 @norm2782 Proper PostgreSQL and resource-pool-catchio implementation
norm2782 authored
87 let pgsql = connectPostgreSQL' =<< readFile "config/connection_string.conf"
88 pool <- liftIO $ createPool pgsql HDBC.disconnect 1 500 1
89 _dblens' <- nestSnaplet "hdbc" dbLens $ hdbcInit pool
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
90 _authlens' <- nestSnaplet "auth" authLens $ initHdbcAuthManager
291b5f3 @norm2782 Proper PostgreSQL and resource-pool-catchio implementation
norm2782 authored
91 defAuthSettings sessLens pool defAuthTable defQueries
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
92 return $ App _authlens' _sesslens' _dblens'
ca6cb7d Snap init
3555003 authored
93
94
87dc952 @norm2782 Some refactoring and cleaning up
norm2782 authored
95 ------------------------------------------------------------------------------
96 -- | Handlers
97
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
98 restrict :: AppHandler b -> AppHandler b -> AppHandler b
99 restrict failH succH = do
100 with sessLens touchSession
87dc952 @norm2782 Some refactoring and cleaning up
norm2782 authored
101 authed <- with authLens isLoggedIn
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
102 if authed
103 then succH
104 else failH
105
106 loginRedir :: AppHandler ()
107 loginRedir = redirect "/login"
108
109 forbiddenH :: AppHandler a
110 forbiddenH = do
111 modifyResponse $ setResponseStatus 403 "Forbidden"
112 writeBS "403 forbidden"
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
113 finishWith =<< getResponse
ca6cb7d Snap init
3555003 authored
114
87dc952 @norm2782 Some refactoring and cleaning up
norm2782 authored
115 siteIndexH :: AppHandler ()
116 siteIndexH = ifTop $ restrict loginRedir (blaze $ template index)
ca6cb7d Snap init
3555003 authored
117
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
118 loginH :: AppHandler ()
119 loginH = withSession sessLens $ do
120 loggedIn <- with authLens isLoggedIn
121 when loggedIn $ redirect "/"
8e19504 @norm2782 Show login form on login page, instead of signup form
norm2782 authored
122 res <- eitherSnapForm loginForm "login-form"
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
123 case res of
124 Left form' -> do
125 didFail <- with sessLens $ do
126 failed <- getFromSession "login-failed"
127 deleteFromSession "login-failed"
128 commitSession
129 return failed
130 blaze $ template $ loginHTML (isJust didFail) form'
131 Right (FormUser e p r) -> do
8e19504 @norm2782 Show login form on login page, instead of signup form
norm2782 authored
132 loginRes <- with authLens $
133 loginByUsername (DT.encodeUtf8 e)
134 (ClearText $ DT.encodeUtf8 p) r
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
135 case loginRes of
136 Left _ -> do with sessLens $ do
137 setInSession "login-failed" "1"
138 commitSession
139 redirect "/login"
140 Right _ -> redirect "/"
f3f1896 Start adding authentication stuff
3555003 authored
141
72c705e @norm2782 Improved form validation
norm2782 authored
142 -- TODO: Also send an email after registration
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
143 signupH :: AppHandler ()
144 signupH = do
145 loggedIn <- with authLens isLoggedIn
146 when loggedIn $ redirect "/"
147 res <- eitherSnapForm registrationForm "registration-form"
148 case res of
653ff73 @norm2782 Handle DuplicateUser exception on registration
norm2782 authored
149 Left form' -> do
150 exists <- with sessLens $ do
151 failed <- getFromSession "username-exists"
152 deleteFromSession "username-exists"
153 commitSession
154 return failed
155 blaze $ template (signupHTML (isJust exists) form')
85063a1 @norm2782 Fix SQL problems
norm2782 authored
156 Right (FormUser e p _) -> do
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
157 _ <- with authLens (createUser e (DT.encodeUtf8 p)) `catch` hndlExcptn
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
158 redirect "/"
653ff73 @norm2782 Handle DuplicateUser exception on registration
norm2782 authored
159 where hndlExcptn :: SomeException -> AppHandler AuthUser
160 hndlExcptn _ = do
161 with sessLens $ do
162 setInSession "username-exists" "1"
163 commitSession
164 redirect "/signup"
ca6cb7d Snap init
3555003 authored
165
87dc952 @norm2782 Some refactoring and cleaning up
norm2782 authored
166 logoutH :: AppHandler ()
167 logoutH = do
168 with authLens logout
169 redirect "/"
ca6cb7d Snap init
3555003 authored
170
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
171 readStoredRulesH :: AppHandler ()
172 readStoredRulesH = restrict forbiddenH $ do
f52fc41 @norm2782 Cleanup and reworking the way we deal with rules
norm2782 authored
173 rules <- getStoredRules =<< getUserId
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
174 modifyResponse $ setContentType "application/json"
175 writeLBS $ encode rules
176
177 deleteStoredRuleH :: AppHandler ()
178 deleteStoredRuleH = restrict forbiddenH $ do
8e19504 @norm2782 Show login form on login page, instead of signup form
norm2782 authored
179 mrid <- getParam "id"
c62f56b @norm2782 Clean up a bit and get rid of some undefineds
norm2782 authored
180 case mrid of
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
181 Nothing -> return ()
c54f6de @norm2782 Merge branch 'pgsql'
norm2782 authored
182 Just x -> do
183 uid <- getUserId
184 deleteRule uid x
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
185
186 addStoredRuleH :: AppHandler ()
187 addStoredRuleH = restrict forbiddenH $ do
c62f56b @norm2782 Clean up a bit and get rid of some undefineds
norm2782 authored
188 rqrl <- readRequestBody 4096
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
189 case mkRule rqrl of
f52fc41 @norm2782 Cleanup and reworking the way we deal with rules
norm2782 authored
190 Left err -> error500H err
191 Right rl -> do
650d354 @norm2782 Return new row ID on rule insertion
norm2782 authored
192 uid <- getUserId
eb02683 @spockz * Deleting of rules now also works. :)
authored
193 insRes <- insertRule uid rl
194 case insRes of
195 (Just newID) -> do modifyResponse $ setContentType "application/json"
196 writeLBS $ encode (AddRes newID)
197 Nothing -> error500H undefined
c5c9ff1 @spockz Merge branch 'master' of git://github.com/norm2782/JCU
authored
198
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
199
200 loadExampleH :: AppHandler ()
201 loadExampleH = restrict forbiddenH $ do
87dc952 @norm2782 Some refactoring and cleaning up
norm2782 authored
202 uid <- getUserId
203 deleteUserRules uid
204 mapM_ (insertRule uid) exampleData
fac9a7a @norm2782 Remove comment
norm2782 authored
205 redirect "/"
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
206
207
87dc952 @norm2782 Some refactoring and cleaning up
norm2782 authored
208 getUserId :: AppHandler UserId
209 getUserId = do
210 cau <- with authLens currentUser
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
211 case cau >>= userId of
87dc952 @norm2782 Some refactoring and cleaning up
norm2782 authored
212 Nothing -> redirect "/"
213 Just x -> return x
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
214
215 -- | Check the proof from the client. Since the checking could potentially
216 -- shoot into an inifinite recursion, a timeout is in place.
217 checkProofH :: AppHandler ()
218 checkProofH = restrict forbiddenH $ do
219 setTimeout 15
e6742c4 @norm2782 Implemented getStoredRules
norm2782 authored
220 body <- readRequestBody 4096
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
221 case mkProof body of
8e19504 @norm2782 Show login form on login page, instead of signup form
norm2782 authored
222 Left err -> error500H err
223 Right proof -> do
f52fc41 @norm2782 Cleanup and reworking the way we deal with rules
norm2782 authored
224 rules <- getStoredRules =<< getUserId
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
225 writeLBS $ encode (checkProof (map rule rules) proof)
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
226
227 unifyH :: AppHandler ()
228 unifyH = restrict forbiddenH $ do
229 setTimeout 10
e6742c4 @norm2782 Implemented getStoredRules
norm2782 authored
230 body <- readRequestBody 4096
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
231 case mkDropReq body of
232 Left err -> error500H err
233 Right (DropReq prf lvl rl) -> writeLBS $ encode (dropUnify prf lvl rl)
234
c62f56b @norm2782 Clean up a bit and get rid of some undefineds
norm2782 authored
235 error500H :: ByteString -> AppHandler a
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
236 error500H msg = do
237 modifyResponse $ setResponseStatus 500 "Internal server error"
bee243c @norm2782 Use fromString instead of explicit packs
norm2782 authored
238 writeBS $ BS.append (fromString "500 internal server error: ") msg
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
239 finishWith =<< getResponse
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
240
241 checkSyntaxH :: AppHandler ()
242 checkSyntaxH = restrict forbiddenH $ do
243 ptype <- getParam "type"
e6742c4 @norm2782 Implemented getStoredRules
norm2782 authored
244 body <- readRequestBody 4096
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
245 writeLBS $ encode (parseCheck ptype body)
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
246
247 substH :: AppHandler ()
248 substH = restrict forbiddenH $ do
e6742c4 @norm2782 Implemented getStoredRules
norm2782 authored
249 body <- readRequestBody 4096
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
250 sub <- getParam "sub"
251 for <- getParam "for"
252 case mkProof body of
53fb218 @norm2782 Minor code formatting
norm2782 authored
253 Left err -> error500H err
87dc952 @norm2782 Some refactoring and cleaning up
norm2782 authored
254 Right proof ->
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
255 case (sub, for) of
256 (Just sub', Just for') ->
9a89acf @norm2782 Wrap form elements in div elements
norm2782 authored
257 let env = Env $ DM.fromList [(BS.unpack for', Var $ BS.unpack sub')]
258 in writeLBS $ encode (subst env proof)
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
259 _ -> writeLBS $ encode proof
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
260
261
87dc952 @norm2782 Some refactoring and cleaning up
norm2782 authored
262 -------------------------------------------------------------------------------
263 -- View rendering
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
264
265 blaze :: Reader AuthState Html -> AppHandler ()
266 blaze htmlRdr = do
267 modifyResponse $ addHeader "Content-Type" "text/html; charset=UTF-8"
e6742c4 @norm2782 Implemented getStoredRules
norm2782 authored
268 li <- with authLens isLoggedIn
269 eml <- with authLens $ do
270 cu <- currentUser
271 return $ case cu of
272 Nothing -> ""
273 Just u -> userLogin u
274 let html = runReader htmlRdr (AuthState li eml)
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
275 writeLBS $ renderHtml html
276
277 -------------------------------------------------------------------------------
278 -- Forms
279
280 data FormUser = FormUser
281 { email :: Text
282 , password :: Text
283 , remember :: Bool }
284 deriving Show
285
286 isEmail :: Monad m => Validator m Html Text
287 isEmail = check "Invalid email address" (E.isValid . DT.unpack)
288
289 longPwd :: Monad m => Validator m Html Text
290 longPwd = check "Password needs to be at least six characters long"
291 $ \xs -> DT.length xs >= 6
292
293 isNonEmpty :: Monad m => Validator m Html Text
294 isNonEmpty = check "Field must not be empty" $ not . DT.null
295
53fb218 @norm2782 Minor code formatting
norm2782 authored
296 identical :: Validator AppHandler Html (Text, Text)
297 identical = check "Field values must be identical" (uncurry (==))
298
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
299 loginForm :: Form AppHandler SnapInput Html BlazeFormHtml FormUser
ab390bb @norm2782 Add form buttons in the forms themselves
norm2782 authored
300 loginForm = (\e p r _ -> FormUser e p r)
9a89acf @norm2782 Wrap form elements in div elements
norm2782 authored
301 <$> mapViewHtml H.div (
302 label "Email address: "
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
303 ++> inputText Nothing `validate` isEmail
9a89acf @norm2782 Wrap form elements in div elements
norm2782 authored
304 <++ errors)
305 <*> mapViewHtml H.div (
306 label "Password: "
05a959d @norm2782 Bump digestive-functors version
norm2782 authored
307 ++> inputPassword False `validate` longPwd
9a89acf @norm2782 Wrap form elements in div elements
norm2782 authored
308 <++ errors)
309 <*> mapViewHtml H.div (
310 label "Remember me?"
311 ++> inputCheckBox True)
312 <*> mapViewHtml H.div (
313 submit "Login")
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
314
315 registrationForm :: Form AppHandler SnapInput Html BlazeFormHtml FormUser
72c705e @norm2782 Improved form validation
norm2782 authored
316 registrationForm = (\ep pp _ -> FormUser (fst ep) (fst pp) False)
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
317 <$> ((,)
9a89acf @norm2782 Wrap form elements in div elements
norm2782 authored
318 <$> mapViewHtml H.div (
319 label "Email address: "
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
320 ++> inputText Nothing `validate` isEmail
321 <++ errors)
9a89acf @norm2782 Wrap form elements in div elements
norm2782 authored
322 <*> mapViewHtml H.div (
323 label "Email address (confirmation): "
324 ++> inputText Nothing `validate` isEmail
325 <++ errors))
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
326 `validate` identical
327 <++ errors
328 <*> ((,)
9a89acf @norm2782 Wrap form elements in div elements
norm2782 authored
329 <$> mapViewHtml H.div (
330 label "Password: "
05a959d @norm2782 Bump digestive-functors version
norm2782 authored
331 ++> inputPassword False `validate` longPwd
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
332 <++ errors)
9a89acf @norm2782 Wrap form elements in div elements
norm2782 authored
333 <*> mapViewHtml H.div (
334 label "Password (confirmation): "
05a959d @norm2782 Bump digestive-functors version
norm2782 authored
335 ++> inputPassword False `validate` longPwd
9a89acf @norm2782 Wrap form elements in div elements
norm2782 authored
336 <++ errors))
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
337 `validate` identical
338 <++ errors
9a89acf @norm2782 Wrap form elements in div elements
norm2782 authored
339 <*> mapViewHtml H.div (
340 submit "Register")
341
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
342
90869cd @norm2782 Get rid of fromJust, clean up and refactor
norm2782 authored
343
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
344 -------------------------------------------------------------------------------
345 -- Database interaction
346
720dd0d @norm2782 Get rid of voidM
norm2782 authored
347 insertRule :: (Functor m, HasHdbc m c s) => UserId -> Rule -> m (Maybe Int)
fac9a7a @norm2782 Remove comment
norm2782 authored
348 insertRule uid rl =
291b5f3 @norm2782 Proper PostgreSQL and resource-pool-catchio implementation
norm2782 authored
349 let sqlVals = [toSql $ unUid uid, toSql $ show rl]
fac9a7a @norm2782 Remove comment
norm2782 authored
350 in do
720dd0d @norm2782 Get rid of voidM
norm2782 authored
351 void $ query' "INSERT INTO rules (uid, rule_order, rule) VALUES (?, 1, ?)" sqlVals
291b5f3 @norm2782 Proper PostgreSQL and resource-pool-catchio implementation
norm2782 authored
352 rws <- query "SELECT rid FROM rules WHERE uid = ? AND rule = ? ORDER BY rid DESC" sqlVals
fac9a7a @norm2782 Remove comment
norm2782 authored
353 return $ case rws of
354 [] -> Nothing
291b5f3 @norm2782 Proper PostgreSQL and resource-pool-catchio implementation
norm2782 authored
355 (x:_) -> Just $ fromSql $ x DM.! "rid"
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
356
720dd0d @norm2782 Get rid of voidM
norm2782 authored
357 deleteRule :: (Functor m, HasHdbc m c s) => UserId -> ByteString -> m ()
358 deleteRule uid rid = void $ query'
0f13a59 @norm2782 Remove `q` workaround
norm2782 authored
359 "DELETE FROM rules WHERE rid = ? AND uid = ?" [toSql rid, toSql uid]
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
360
b435a8c @norm2782 Convert to the latest snaplet-hdbc
norm2782 authored
361 getStoredRules :: HasHdbc m c s => UserId -> m [DBRule]
f72a9fe @norm2782 First stab at porting the app to Snap 0.6 and HDBC
norm2782 authored
362 getStoredRules uid = do
291b5f3 @norm2782 Proper PostgreSQL and resource-pool-catchio implementation
norm2782 authored
363 rws <- query "SELECT rid, rule_order, rule FROM rules WHERE uid = ?" [toSql uid]
5e2391d @norm2782 Remove snaplet-hdbc for now
norm2782 authored
364 return $ map convRow rws
892e3a3 @norm2782 More in progress
norm2782 authored
365 where convRow :: Map String HDBC.SqlValue -> DBRule
e6742c4 @norm2782 Implemented getStoredRules
norm2782 authored
366 convRow mp =
367 let rdSql k = fromSql $ mp DM.! k
368 in DBRule (rdSql "rid")
369 (rdSql "rule_order")
7724fd6 @norm2782 Use ListLike CS and CSL to forego unpacking of ByteStrings
norm2782 authored
370 (fst . startParse pRule $ CS (rdSql "rule"))
c62f56b @norm2782 Clean up a bit and get rid of some undefineds
norm2782 authored
371
720dd0d @norm2782 Get rid of voidM
norm2782 authored
372 deleteUserRules :: (Functor m, HasHdbc m c s) => UserId -> m ()
373 deleteUserRules uid = void $ query'
0f13a59 @norm2782 Remove `q` workaround
norm2782 authored
374 "DELETE FROM rules WHERE uid = ?" [toSql uid]
c62f56b @norm2782 Clean up a bit and get rid of some undefineds
norm2782 authored
375
Something went wrong with that request. Please try again.