haskellblog / src / Blog / Views.hs

Luke Plant 5626918 
Luke Plant 4af1762 

Luke Plant de172ca 

Luke Plant 695cc38 

Luke Plant 7a2bb47 
Luke Plant a4b80a5 
Luke Plant e478875 
Luke Plant fbbb971 
Luke Plant 695cc38 


Luke Plant 49b1fad 
Luke Plant 9635e27 
Luke Plant a608b96 
Luke Plant 8508eb6 


Luke Plant 574cc73 
Luke Plant 5aa538d 
Luke Plant 6fd4ef4 
Luke Plant 7a2bb47 

Luke Plant 9f5848a 

Luke Plant 7a2bb47 
Luke Plant 0c6f381 
Luke Plant 02cb28b 
Luke Plant 574cc73 
Luke Plant 695cc38 

Luke Plant 3558136 


Luke Plant 5626918 
Luke Plant 935938e 



Luke Plant ecd83e6 



Luke Plant 3558136 
Luke Plant 9f5848a 


Luke Plant 6fd4ef4 
Luke Plant fbbb971 
Luke Plant a1ce777 
Luke Plant fbbb971 


Luke Plant 5aa538d 

Luke Plant 3613bec 
Luke Plant fbbb971 

Luke Plant 935938e 

Luke Plant acf658a 


Luke Plant 3717fda 
Luke Plant acf658a 

Luke Plant 6fd4ef4 
Luke Plant 69dbd94 







Luke Plant 7a2bb47 






Luke Plant 935938e 



Luke Plant f89ed5f 
Luke Plant 2c3e9aa 
Luke Plant f89ed5f 
Luke Plant 2c3e9aa 
Luke Plant 89c760c 
Luke Plant 7b2c8c8 
Luke Plant 64de167 
Luke Plant fbbb971 
Luke Plant f4a4229 



Luke Plant b360bc9 
Luke Plant f4a4229 
Luke Plant 2ee1060 
Luke Plant 7a2bb47 






Luke Plant 40868dc 













Luke Plant 7a2bb47 

Luke Plant 40868dc 

Luke Plant bfa3488 
Luke Plant de172ca 

Luke Plant 50c5ddd 
Luke Plant 9f5848a 
Luke Plant bfa3488 
Luke Plant 9f5848a 
Luke Plant bfa3488 
Luke Plant ecd83e6 

Luke Plant de172ca 


Luke Plant ecd83e6 
Luke Plant de172ca 
Luke Plant f89ed5f 
Luke Plant 55aa573 


Luke Plant ce6f383 
Luke Plant 9f5848a 
Luke Plant fbbb971 
Luke Plant 2ee1060 



Luke Plant 720add2 
Luke Plant de172ca 
Luke Plant 49b1fad 
Luke Plant f89ed5f 




Luke Plant acf658a 
Luke Plant f89ed5f 
Luke Plant 528db92 
Luke Plant 6a02304 
Luke Plant 1f1a44d 
Luke Plant fbbb971 
Luke Plant 1f1a44d 




Luke Plant b360bc9 
Luke Plant 1f1a44d 
Luke Plant 6fd4ef4 
Luke Plant 7a2bb47 





Luke Plant 528db92 
Luke Plant 7a2bb47 
Luke Plant d8c16e6 
Luke Plant 9087f7e 
Luke Plant 49b1fad 
Luke Plant 2d5d221 



Luke Plant acf658a 
Luke Plant 78a5ae8 
Luke Plant c797d00 
Luke Plant 78a5ae8 
Luke Plant 38d2fc5 
Luke Plant b865b65 
Luke Plant 5626918 
Luke Plant fbbb971 
Luke Plant 5626918 





Luke Plant 5b2e07d 
Luke Plant 5626918 




Luke Plant 126cf66 
Luke Plant b7d705f 
Luke Plant c797d00 
Luke Plant b360bc9 

Luke Plant d8bd68e 
Luke Plant 5626918 
Luke Plant 9087f7e 
Luke Plant 98b4fd8 


Luke Plant 2a184ac 
Luke Plant 7cbd001 
Luke Plant 5b2e07d 
Luke Plant 2ba5e75 
Luke Plant 5b2e07d 



Luke Plant c797d00 
Luke Plant 2ba5e75 
Luke Plant 5b2e07d 
Luke Plant 98b4fd8 
Luke Plant c797d00 
Luke Plant 5b2e07d 
Luke Plant 98b4fd8 
Luke Plant 7a2bb47 







Luke Plant 9087f7e 
Luke Plant e4622ce 
Luke Plant 3495320 
Luke Plant 7c36141 








Luke Plant fdfdfa4 
Luke Plant 5b2e07d 
Luke Plant 7c36141 
Luke Plant bb0c8ec 

Luke Plant 3613bec 

Luke Plant c051c4a 

Luke Plant fbbb971 
Luke Plant 7c36141 
Luke Plant c051c4a 
Luke Plant 5b2e07d 
Luke Plant 7c36141 
Luke Plant c051c4a 

Luke Plant 5b2e07d 

Luke Plant c051c4a 

Luke Plant 695cc38 
Luke Plant c051c4a 
Luke Plant 695cc38 
Luke Plant 23ad47a 

Luke Plant 5aa538d 

Luke Plant 23ad47a 
Luke Plant 0c6f381 






Luke Plant 89c760c 
Luke Plant 02cb28b 




Luke Plant 462e72a 


Luke Plant 02cb28b 

Luke Plant 89c760c 










Luke Plant 02cb28b 
Luke Plant 0cd1645 
Luke Plant 0c6f381 












Luke Plant e478875 
Luke Plant 0c6f381 











Luke Plant 9b26a5e 
Luke Plant 0c6f381 









Luke Plant a608b96 
Luke Plant 0cd1645 
Luke Plant e478875 






Luke Plant 0cd1645 
Luke Plant e478875 







Luke Plant 574cc73 































Luke Plant e478875 
Luke Plant 574cc73 




Luke Plant e478875 





Luke Plant 574cc73 



Luke Plant e478875 

Luke Plant 74f2d3e 



Luke Plant a4b80a5 


Luke Plant 74f2d3e 

Luke Plant a4b80a5 









Luke Plant 7086193 


Luke Plant a4b80a5 

Luke Plant 74f2d3e 

Luke Plant a4b80a5 





Luke Plant dc9acd9 




Luke Plant ccbf534 




Luke Plant dc9acd9 
Luke Plant ccbf534 
Luke Plant 74f2d3e 
Luke Plant 7a2bb47 
Luke Plant bb0c8ec 
Luke Plant 695cc38 
Luke Plant 1443181 
Luke Plant bb0c8ec 
Luke Plant 6fd4ef4 


Luke Plant bb0c8ec 
Luke Plant 695cc38 
Luke Plant 7c36141 
Luke Plant a608b96 

Luke Plant c6b1201 

Luke Plant a608b96 


Luke Plant c6b1201 
Luke Plant a608b96 
Luke Plant 1443181 
Luke Plant a608b96 
Luke Plant 69dbd94 












Luke Plant 4558222 
Luke Plant f89ed5f 

Luke Plant 82fded5 
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
{-# OPTIONS_GHC -fglasgow-exts -fcontext-stack=30 #-}
module Blog.Views where

-- View functions and logic. The actual HTML is found in Templates,
-- which has pure functions that generally return Html.

import Blog.DB (connect)
import Blog.Feeds
import Blog.Formats (Format(..), getFormatter)
import Blog.Forms
import Blog.Globals (mkCsrfField)
import Blog.Links
import Blog.Model
import Blog.Templates
import Ella.Framework (default404, View)
import Ella.GenUtils (utf8, with, exactParse, getTimestamp)
import Ella.Param (captureOrDefault, capture)
import Ella.Request
import Ella.Response
import Ella.Utils (addHtml)
import Maybe (fromMaybe, isJust, fromJust, catMaybes)
import Network.CGI.Protocol (formEncode, urlEncode)
import System.Time (ClockTime(..), toUTCTime)
import Text.Atom.Feed (Feed)
import Text.Atom.Feed.Export (xmlFeed)
import Text.StringTemplate
import Text.StringTemplate.GenericStandard
import Text.XML.Light (showTopElement)
import qualified Blog.Category as Ct
import qualified Blog.Links as Links
import qualified Blog.Post as P
import qualified Blog.Settings as Settings
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as LB
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import qualified Text.XHtml as X

---- Utilities

-- | Generate a standard response, given the HTML to add.
standardResponse html = buildResponse [
                         addHtml html
                        ] utf8HtmlResponse

standardResponseBS :: LB.ByteString -> Response
standardResponseBS content = buildResponse [
                              addContent content
                             ] utf8HtmlResponse

-- | Standard response, taking a Request and StringTemplate Text as input
standardResponseTT :: Request -> StringTemplate LB.ByteString -> Response
standardResponseTT req template =
    let csrffield = mkCsrfField req
        t2 = setAttribute "csrffield" csrffield template
        qs = formEncode (allGET req)
        t3 = setAttribute "currentpath" (urlEncode (Settings.root_url ++ pathInfo req ++ (if not $ null qs then "?" ++ qs else ""))) t2
        rendered = render t3
    in buildResponse [ addContent rendered
                     ] utf8HtmlResponse

-- | Custom 404 response
return404 :: View
return404 req = do
  t <- get_template "notfound"
  return $ Just $ with (standardResponseTT req t) [
                        setStatus 404
                       ]

return403 :: View
return403 req = do
  t <- get_template "forbidden"
  return $ Just $ with (standardResponseTT req t) [
                 setStatus 403
                ]


-- Feed utilities

feedResponse :: Feed -> IO (Maybe Response)
feedResponse feed = return $ Just $
                    with (textBasedResponse "application/atom+xml" "UTF-8")
                             [ addContent $ utf8 $ showTopElement $ xmlFeed feed
                             ]

---- Views

-- View for the main page
mainIndex :: View
mainIndex req = do
  let curpage = getPage req
  cn <- connect
  (posts,more) <- getRecentPosts cn curpage Settings.post_page_size
  cats <- getCategoriesBulk cn posts
  t <- get_template "index"
  return $ Just $ standardResponseTT req $
             (renderf t
              ("posts", map postTemplateInfo posts)
              ("categories", map (map categoryTemplateInfo) cats)
              ("paginglinks", pagingLinks indexUrl curpage more)
              ("atomfeedurl", allPostsFeedUrl)
             )

-- Feed for all posts
allPostsFeedView req = do
  cn <- connect
  (posts, more) <- getRecentPosts cn 1 Settings.feed_post_page_size
  feedResponse $ allPostsFeed posts


allCommentsView req = do
  let curpage = getPage req
  cn <- connect
  (commentsAndPosts,more) <- getRecentComments cn curpage Settings.comment_page_size
  t <- get_template "comments"
  return $ Just $ standardResponseTT req $
                      (renderf t
                       ("comments", map (commentTemplateInfo . fst) commentsAndPosts)
                       ("urls", map (uncurry commentUrl) commentsAndPosts)
                       ("titles", map (P.title . snd) commentsAndPosts)
                       ("paginglinks", pagingLinks allCommentsUrl curpage more)
                       ("atomfeedurl", allCommentsFeedUrl)
                      )

allCommentsFeedView req = do
  cn <- connect
  (commentsAndPosts,more) <- getRecentComments cn 1 Settings.feed_comment_page_size
  feedResponse $ allCommentsFeed commentsAndPosts

-- | View to help with debugging
debug :: String -> View
debug path req = return $ Just $ buildResponse [
                  addContent $ utf8 "Path:\n"
                 , addContent $ utf8 path
                 , addContent $ utf8 "\n\nRequest:\n"
                 , addContent $ utf8 $ show req
                 ] utf8TextResponse

-- | View that performs redirect to main page
postsRedirectView :: View
postsRedirectView req = return $ Just $ redirectResponse indexUrl

-- | View that shows an overview of categories
categoriesView :: View
categoriesView req = do
  cn <- connect
  cats <- getCategories cn
  t <- get_template "categories"
  let categories = [ (c, categoryUrl c) | c <- cats ]
  return $ Just $ standardResponseTT req $
             (renderf t
              ("categories", categories)
              ("hasCategories", not $ null cats)
             )

-- | View that shows posts for an individual category
categoryView :: String -> View
categoryView slug req = do
  let curpage = getPage req
  cn <- connect
  mcat <- getCategoryBySlug cn slug
  case mcat of
    Nothing -> return404 req
    Just cat -> do
              (posts,more) <- getPostsForCategory cn cat (getPage req) Settings.post_page_size
              cats <- getCategoriesBulk cn posts
              t <- get_template "category"
              return $ Just $ standardResponseTT req $
                         (renderf t
                          ("category", cat)
                          ("posts", map postTemplateInfo posts)
                          ("categories", map (map categoryTemplateInfo) cats)
                          ("paginglinks", pagingLinks (categoryUrl cat) curpage more)
                          ("atomfeedurl", categoryPostsFeedUrl cat)
                         )

categoryPostsFeedView slug req = do
  cn <- connect
  mcat <- getCategoryBySlug cn slug
  case mcat of
    Nothing -> return404 req
    Just cat -> do
              (posts,more) <- getPostsForCategory cn cat 1 Settings.feed_post_page_size
              feedResponse $ categoryPostsFeed cat posts

-- | View that shows individual post
postView :: String -> View
postView slug req = do
  cn <- connect
  mp <- getPostBySlug cn slug
  case mp of
    Nothing -> return404 req
    Just post -> do
            (commentStage, commentData, commentErrors, commentExtra) <- handleUserComment cn post req
            cats <- getCategoriesForPost cn post
            comments <- getCommentsForPost cn post
            related <- getRelatedPosts cn post cats
            t <- get_template "post"
            return $ Just $ standardResponseTT req $
                       (renderf t
                        ("post", postTemplateInfo post)
                        ("commentPreview", commentStage == CommentPreview)
                        ("commentAccepted", commentStage == CommentAccepted)
                        ("commentInvalid", commentStage == CommentInvalid)
                        ("newComment", commentTemplateInfo commentData)
                        ("commentErrors", commentErrors)
                        ("categories", map categoryTemplateInfo cats)
                        ("comments", map commentTemplateInfo comments)
                        ("hasComments", not $ null comments)
                        ("related", map postTemplateInfo related)
                        ("hasRelated", not $ null related)
                        ("commentData", commentData)
                        ("formatWidget", X.toHtml $ formatWidgetForComment commentData)
                        ("commentExtra", commentExtra)
                        ("atomfeedurl", postCommentFeedUrl post)
                        ("atomfeedtitle", "Atom feed for comments in this post")
                        ("editpageurl", adminEditPostUrl post)
                       )
  where
    handleUserComment cn post req =
        case requestMethod req of
          "POST" -> do
            creds <- getCredentials req
            (commentData, commentErrors, commentExtra) <- validateComment cn creds (getPOST req) post
            if null commentErrors
               then if isJust (getPOST req "submit")
                    then do
                      addComment cn commentData
                      return (CommentAccepted, emptyComment, [], commentExtra)
                    -- Just assume 'preview' if not 'submit'
                    else return (CommentPreview, commentData, commentErrors, commentExtra)
               else
                 return (CommentInvalid, commentData, commentErrors, commentExtra)

          _ -> do commentExtra <- initialCommentExtra req
                  return (NoComment, emptyComment, [], commentExtra)

postCommentFeedView slug req = do
  cn <- connect
  mp <- getPostBySlug cn slug
  case mp of
    Nothing -> return404 req
    Just post -> do
            comments <- getCommentsForPost cn post
            feedResponse $ postCommentFeed comments post


-- | View that displays a login form and handles logging in
loginView :: View
loginView req = do
  cn <- connect
  loginView' cn req

-- | Testable version of loginView
loginView' cn req =
  case requestMethod req of
    "POST" -> do
      (loginData, loginErrors) <- validateLogin (getPOST req) cn
      if null loginErrors
         then do
           ts <- getTimestamp
           let loginCookies = createLoginCookies loginData ts
           let redirectUrl = getGET req "r" `captureOrDefault` adminMenuUrl
           return $ Just $ (redirectResponse redirectUrl) `with` (map addCookie loginCookies)
         else do
           t <- loginTemplate
           return $ Just $ standardResponseTT req $ loginPage t loginData loginErrors
    _ -> do
      t <- loginTemplate
      return $ Just $ standardResponseTT req $ loginPage t emptyLoginData ([] :: [(String,String)])

  where loginPage t loginData loginErrors =
            (renderf t
             ("loginInvalid", not $ null loginErrors)
             ("loginErrors", loginErrors)
             ("loginData", loginData)
            )

        loginTemplate = get_template "login"

-- | Delete auth cookies and redirect.
logoutView req =
    let redirectUrl = getGET req "r" `captureOrDefault` indexUrl
    in return $ Just $ deleteCookie "username" $ redirectResponse redirectUrl

--
-- Admin views
--

-- Category editing is very simple and doesn't require
-- much validation.

adminMenu :: View
adminMenu req = do
  t <- get_template "admin_menu"
  return $ Just $ standardResponseTT req $
         (renderf t
          ("pagetitle", "Blog admin - menu")
          ("adminNewPostUrl", Links.adminNewPostUrl)
          ("adminPostsUrl", Links.adminPostsUrl)
          ("adminCategoriesUrl", Links.adminCategoriesUrl)
         )

adminPosts req = do
  t <- get_template "admin_posts"
  let curpage = getPage req
  cn <- connect
  (posts,more) <- getRecentPosts cn curpage Settings.admin_post_page_size
  return $ Just $ standardResponseTT req $
             (renderf t
              ("pagetitle", "Edit posts")
              ("posts", map postTemplateInfo posts)
              ("paginglinks", pagingLinks Links.adminPostsUrl curpage more)
             )

-- | View that handles all editing of categories (add/edit/delete)
adminCategories req = do
  cn <- connect
  t <- get_template "admin_categories"
  -- handle deletion if "delete" in POST vars
  -- handle adding/editing if "save" in POST vars
  message <- handlePost req cn
  categories <- getCategories cn
  return $ Just $ standardResponseTT req $
         (renderf t
          ("categories", categories)
          ("message", message)
          ("showMessage", length message > 0)
         )
  where
      handlePost req cn =
          if requestMethod req == "POST"
          then if isJust (getPOST req "save")
               then
                   let catid = (getPOST req "catid") `captureOrDefault` 0 :: Int
                   in if catid == 0
                      then do
                        let ct = Ct.newCategory (getPOST req "name" `captureOrDefault` "")
                        addCategory cn ct
                        return "Category added"
                      else do
                        Just ct <- getCategoryById cn catid
                        let ct2 = ct { Ct.name = utf8 (getPOST req "name" `captureOrDefault` "") }
                        updateCategory cn ct2
                        return ("Category " ++ show catid ++ " saved")
               else if isJust (getPOST req "delete")
                    then
                        let catid = (getPOST req "categories") `captureOrDefault` 0 :: Int
                        in do
                          deleteCategory cn catid
                          return ("Category " ++ show catid ++ " deleted")
                    else return ""
          else return ""

-- | View that handles editing an existing blog post
adminEditPost post_id req = do
  cn <- connect
  m_post <- getPostById cn post_id
  case m_post of
    Just p -> adminEditPost' p False cn req
    Nothing -> return404 req

-- | View that handles adding a new blog post
adminNewPost req = do
  cn <- connect
  adminEditPost' emptyPost True cn req

adminEditPost' post isNew cn req = do
  categories <- getCategories cn
  postCategories <- if isNew then return [] else getCategoriesForPost cn post
  case requestMethod req of
    "GET" ->  output post (map Ct.uid postCategories) categories "start" []
    "POST" -> do
      let mode = head $ map fst $ filter snd $  [ ("submit", hasPOST req "submit")
                                                , ("delete", hasPOST req "delete")
                                                -- use preview as default, for simplicity
                                                , ("preview", True)
                                                ]
      if mode == "delete"
        then do
          deletePost cn (P.uid post)
          return $ Just $ redirectResponse adminMenuUrl
        else do
          (postData, postCatIds, postErrors) <- validatePost req post
          if null postErrors
            then
              if mode == "submit"
                then do
                  if isNew
                    then do
                      -- Set timestamp here, because we don't want to do it in
                      -- validatePost (we would need to pass in isNew)
                      ts <- getTimestamp
                      let newPost = postData { P.timestamp = ts }
                      addPost cn newPost postCatIds
                    else updatePost cn postData postCatIds
                  return $ Just $ redirectResponse adminMenuUrl
              else do
                -- mode == "preview"
                output postData postCatIds categories mode postErrors
            else
                -- invalid
                output postData postCatIds categories "invalid" postErrors
  where
    output :: P.Post -> [Int] -> [Ct.Category] -> String -> [(String, String)] -> IO (Maybe Response)
    output postData postCatIds categories mode errors =
        do
          t <- get_template "admin_post"
          return $ Just $ standardResponseTT req $
                                   (renderf t
                                    ("post", postData)
                                    ("categoriesWidget", X.toHtml $ categoriesWidgetForPost postCatIds categories)
                                    ("formatWidget", X.toHtml $ formatWidgetForPost postData)
                                    ("isNew", isNew)
                                    ("pagetitle", if isNew then "Add post" else "Edit post")
                                    ("mode", mode)
                                    ("errors", errors)
                                    ("showErrors", not $ null errors)
                                    ("showPreview", mode == "preview")
                                   )


-- Admin AJAX

-- TODO - proper JSON objects
simpleMessage msg = buildResponse [ addContent $ utf8 msg ] utf8TextResponse
success = simpleMessage "success"
failure = simpleMessage "failure"

adminCommentVisible req = do
  let visible   = getPOST req "visible" `captureOrDefault` False
  withValidComment req (\cn commentId -> setCommentVisible cn commentId visible)

adminCommentResponse req = do
  let response  = getPOST req "response" `captureOrDefault` "" :: String
  let formattedResponse = getFormatter Plaintext $ response
  withValidComment req (\cn commentId -> setCommentResponse cn commentId formattedResponse)
  return $ Just $ simpleMessage formattedResponse
  -- TODO - proper error handling

adminCommentDelete req = do
  withValidComment req deleteComment

-- Utility that pulls out common functionality of adminComment*
withValidComment req action = do
  let commentId = getPOST req "id" `captureOrDefault` 0 :: Int
  if commentId <= 0
     then return $ Just $ failure
     else do
       cn <- connect
       action cn commentId
       return $ Just success

addSpamWordView = withSpamWord addSpamWord

deleteSpamWordView = withSpamWord deleteSpamWord

withSpamWord action req = do
  let word = getPOST req "word" `captureOrDefault` ""
  if null word
     then return $ Just $ failure
     else do
       cn <- connect
       action cn word
       return $ Just success

-- Authentication
createLoginCookies loginData timestamp =
  let username = fromJust $ Map.lookup "username" loginData
      expires = Just $ toUTCTime $ TOD (toInteger timestamp + Settings.login_session_length) 0
  in [ standardCookie { cookieName = "username"
                      , cookieValue = username
                      , cookieExpires = expires
                      }
     ]


timeout = 3600 * 24 * 10 -- 10 days

type Credentials = Maybe String

-- | Return the username if logged in, otherwise Nothing
--
-- Relies on secure cookies middleware
getCredentials :: Request -> IO Credentials
getCredentials req = do
  return $ getCookieVal req "username"

-- Decorators

-- | Decorate a view function with this to limit the view
-- to users who are 'admins'

adminRequired :: View -> View
adminRequired view = \req -> do
  creds <- getCredentials req
  case creds of
    Just n -> if n `elem` Settings.admin_usernames
              then view req
              else return403 req
    Nothing -> return403 req

-- Utilities

getPage req = (getGET req "p") `captureOrDefault` 1 :: Int
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.