gdritter repos new-inf-blog / 0a84539
Flip arguments to runDB for more natural uses Getty Ritter 6 years ago
3 changed file(s) with 22 addition(s) and 18 deletion(s). Collapse all Expand all
+7
-3
src/Inf/DB/Monad.hs less more
22 {-# LANGUAGE RankNTypes #-}
33
44 module Inf.DB.Monad
5 ( DB(..)
5 ( DB
6 , runDB
67 , DBException(..)
78 , SQL.Only(..)
89 , SQL.Connection
2526
2627 import Inf.Types
2728
28 newtype DB r = DB { runDB :: SQL.Connection -> IO r }
29 runDB :: SQL.Connection -> DB a -> IO a
30 runDB c db = fromDB db c
31
32 newtype DB r = DB { fromDB :: SQL.Connection -> IO r }
2933
3034 instance Functor DB where
3135 fmap fn (DB k) = DB (fmap fn . k)
3842 instance Monad DB where
3943 DB x >>= fn = DB $ \ c -> do
4044 x' <- x c
41 runDB (fn x') c
45 fromDB (fn x') c
4246
4347
4448 io :: IO a -> DB a
+1
-1
src/Inf/Web/Cookies.hs less more
5050 -> IO (Maybe TS.Text)
5151 verifyUser conn user passwd = do
5252 let userTxt = EncodingS.decodeUtf8 user
53 authMb <- DB.runDB (DB.userAuthData userTxt) conn
53 authMb <- DB.runDB conn (DB.userAuthData userTxt)
5454 case authMb of
5555 Nothing -> do
5656 Log.warn [ "unable to find login data for", TS.unpack userTxt ]
+14
-14
src/Main.hs less more
2626 user <- Web.getUser c (lookup HTTP.hCookie (W.requestHeaders req))
2727 case (W.requestMethod req, W.pathInfo req) of
2828 ("GET", []) -> do
29 post <- DB.runDB DB.newestPostRef c
29 post <- DB.runDB c DB.newestPostRef
3030 Web.redirect (postRefURL post)
3131
3232 ("POST", []) ->
5050 Log.error [ "bad input data somehow" ]
5151 Web.redirect "/"
5252 Just rp -> do
53 DB.runDB (DB.submitPost (User u) rp) c
53 DB.runDB c (DB.submitPost (User u) rp)
5454 Web.redirect "/newest"
5555
5656 ("GET", ["auth"]) -> do
5858 Web.ok user "login" password
5959
6060 ("GET", ["archive"]) -> do
61 posts <- DB.runDB DB.allPostRefs c
61 posts <- DB.runDB c DB.allPostRefs
6262 contents <- Template.list posts
6363 Web.ok user "Past Entries" contents
6464
7070 Web.ok user "New Post" contents
7171
7272 ("GET", [y, m, s]) -> do
73 (post, cached) <- flip DB.runDB c $ do
73 (post, cached) <- DB.runDB c $ do
7474 ps <- DB.postByDateAndSlug y m s
7575 ch <- DB.cachedMarkup (postId ps)
7676 pure (ps, ch)
7979 Web.ok user (T.fromStrict (postTitle post)) cache
8080 Nothing -> do
8181 contents <- Template.post user post
82 DB.runDB (DB.storeCachedMarkup (postId post) contents) c
82 DB.runDB c (DB.storeCachedMarkup (postId post) contents)
8383 Web.ok user (T.fromStrict (postTitle post)) contents
8484
8585 ("POST", [y, m, s]) ->
8989 Web.redirect "/"
9090 Just u -> do
9191 formData <- Web.formData req
92 oldPost <- DB.runDB (DB.postByDateAndSlug y m s) c
92 oldPost <- DB.runDB c (DB.postByDateAndSlug y m s)
9393 let rpMb = do
9494 title <- join (lookup "title" formData)
9595 contents <- join (lookup "contents" formData)
104104 Log.error [ "bad input data somehow" ]
105105 Web.redirect "/"
106106 Just rp -> do
107 DB.runDB (DB.submitPost (User u) rp) c
107 DB.runDB c (DB.submitPost (User u) rp)
108108 Web.redirect (postURL oldPost)
109109
110110 ("GET", [y, m, s, "edit"]) ->
113113 Log.error [ "non-logged-in user attempted to edit post" ]
114114 Web.redirect "/"
115115 Just {} -> do
116 oldPost <- DB.runDB (DB.postByDateAndSlug y m s) c
116 oldPost <- DB.runDB c (DB.postByDateAndSlug y m s)
117117 contents <- Template.edit (postURL oldPost) (postToRawPost oldPost)
118118 Web.ok user (T.fromStrict (postTitle oldPost)) contents
119119
122122 Nothing -> Web.redirect "/"
123123 Just _ -> do
124124 Log.warn [ "deleting post:", show (y, m, s) ]
125 flip DB.runDB c $ do
125 DB.runDB c $ do
126126 post <- DB.postByDateAndSlug y m s
127127 DB.deletePost (postToRawPost post)
128128 Web.redirect "/"
131131 case user of
132132 Nothing -> Web.redirect "/"
133133 Just _ -> do
134 post <- DB.runDB (DB.postByDateAndSlug y m s) c
134 post <- DB.runDB c (DB.postByDateAndSlug y m s)
135135 contents <- Template.delete post
136136 Web.ok user "Delete Post?" contents
137137
156156 Web.redirectWithCookies "/" [("USERDATA", "")]
157157
158158 ("GET", ["newest"]) -> do
159 post <- DB.runDB DB.newestPostRef c
159 post <- DB.runDB c DB.newestPostRef
160160 Web.redirect (postRefURL post)
161161
162162 ("GET", ["oldest"]) -> do
163 post <- DB.runDB DB.oldestPostRef c
163 post <- DB.runDB c DB.oldestPostRef
164164 Web.redirect (postRefURL post)
165165
166166 ("GET", ["static", fp]) ->
168168 in pure (W.responseFile HTTP.status200 [] path Nothing)
169169
170170 ("GET", ["rss"]) -> do
171 posts <- DB.runDB DB.allPosts c
171 posts <- DB.runDB c DB.allPosts
172172 feed <- Feed.renderFeed posts
173173 Web.atomFeed feed
174174
175175 ("GET", [pagename]) -> do
176 pg <- DB.runDB (DB.staticPage pagename) c
176 pg <- DB.runDB c (DB.staticPage pagename)
177177 contents <- Template.page (pageText pg)
178178 Web.ok user (T.fromStrict pagename) contents
179179