/
Add.hs
92 lines (81 loc) · 2.85 KB
/
Add.hs
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
module Handler.Add where
import Import
import Handler.Archive
import Data.List (nub)
import qualified Data.Text as T (replace)
-- View
getAddViewR :: Handler Html
getAddViewR = do
userId <- requireAuthId
murl <- lookupGetParam "url"
mBookmarkDb <- runDB (fetchBookmarkByUrl userId murl)
let mformdb = fmap _toBookmarkForm mBookmarkDb
formurl <- bookmarkFormUrl
let renderEl = "addForm" :: Text
popupLayout do
toWidget [whamlet|
<div id="#{ renderEl }">
|]
toWidgetBody [julius|
app.dat.bmark = #{ toJSON (fromMaybe formurl mformdb) };
|]
toWidget [hamlet|
<script type="module">
import { renderAddForm } from '@{StaticR js_dist_Add_index_js}'
renderAddForm('##{renderEl}')(app.dat.bmark)();
|]
bookmarkFormUrl :: Handler BookmarkForm
bookmarkFormUrl = do
Entity _ user <- requireAuth
url <- lookupGetParam "url" <&> fromMaybe ""
title <- lookupGetParam "title"
description <- lookupGetParam "description" <&> fmap Textarea
tags <- lookupGetParam "tags"
private <- lookupGetParam "private" <&> fmap parseChk <&> (<|> Just (userPrivateDefault user))
toread <- lookupGetParam "toread" <&> fmap parseChk
pure $
BookmarkForm
{ _url = url
, _title = title
, _description = description
, _tags = tags
, _private = private
, _toread = toread
, _bid = Nothing
, _slug = Nothing
, _selected = Nothing
, _time = Nothing
, _archiveUrl = Nothing
}
where
parseChk s = s == "yes" || s == "on" || s == "true" || s == "1"
-- API
postAddR :: Handler Text
postAddR = do
bookmarkForm <- requireCheckJsonBody
_handleFormSuccess bookmarkForm >>= \case
Created bid -> sendStatusJSON created201 bid
Updated _ -> sendResponseStatus noContent204 ()
Failed s -> sendResponseStatus status400 s
_handleFormSuccess :: BookmarkForm -> Handler (UpsertResult (Key Bookmark))
_handleFormSuccess bookmarkForm = do
(userId, user) <- requireAuthPair
appSettings <- appSettings <$> getYesod
case (appAllowNonHttpUrlSchemes appSettings, (parseRequest . unpack . _url) bookmarkForm) of
(False, Nothing) -> pure $ Failed "Invalid URL"
(_, _) -> do
let mkbid = toSqlKey <$> _bid bookmarkForm
tags = maybe [] (nub . words . T.replace "," " ") (_tags bookmarkForm)
bm <- liftIO $ _toBookmark userId bookmarkForm
res <- runDB (upsertBookmark userId mkbid bm tags)
forM_ (maybeUpsertResult res) $ \kbid ->
whenM (shouldArchiveBookmark user kbid) $
void $ async (archiveBookmarkUrl kbid (unpack (bookmarkHref bm)))
pure res
postLookupTitleR :: Handler ()
postLookupTitleR = do
void requireAuthId
bookmarkForm <- (requireCheckJsonBody :: Handler BookmarkForm)
fetchPageTitle (unpack (_url bookmarkForm)) >>= \case
Left _ -> sendResponseStatus noContent204 ()
Right title -> sendResponseStatus ok200 title