/
Notes.hs
215 lines (199 loc) · 6.82 KB
/
Notes.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
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
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-# LANGUAGE TupleSections #-}
module Handler.Notes where
import Import
import Handler.Common (lookupPagingParams)
import qualified Data.Aeson as A
import qualified Data.Text as T
import Yesod.RssFeed
import qualified Text.Blaze.Html5 as H
getNotesR :: UserNameP -> Handler Html
getNotesR unamep@(UserNameP uname) = do
mauthuname <- maybeAuthUsername
(limit', page') <- lookupPagingParams
let queryp = "query"
mquery <- lookupGetParam queryp
let limit = maybe 20 fromIntegral limit'
page = maybe 1 fromIntegral page'
mqueryp = fmap (queryp,) mquery
isowner = Just uname == mauthuname
(bcount, notes) <- runDB do
Entity userId user <- getBy404 (UniqueUserName uname)
let sharedp = if isowner then SharedAll else SharedPublic
when (not isowner && userPrivacyLock user)
(redirect (AuthR LoginR))
getNoteList userId mquery sharedp limit page
req <- getRequest
mroute <- getCurrentRoute
defaultLayout do
rssLink (NotesFeedR unamep) "feed"
let pager = $(widgetFile "pager")
search = $(widgetFile "search")
renderEl = "notes" :: Text
$(widgetFile "notes")
toWidgetBody [julius|
app.userR = "@{UserR unamep}";
app.dat.notes = #{ toJSON notes } || [];
app.dat.isowner = #{ isowner };
|]
toWidget [julius|
PS['Main'].renderNotes('##{rawJS renderEl}')(app.dat.notes)();
|]
getNoteR :: UserNameP -> NtSlug -> Handler Html
getNoteR unamep@(UserNameP uname) slug = do
mauthuname <- maybeAuthUsername
let renderEl = "note" :: Text
isowner = Just uname == mauthuname
note <-
runDB $
do Entity userId user <- getBy404 (UniqueUserName uname)
mnote <- getNote userId slug
note <- maybe notFound pure mnote
when (not isowner && (userPrivacyLock user || (not . noteShared . entityVal) note))
(redirect (AuthR LoginR))
pure note
defaultLayout do
$(widgetFile "note")
toWidgetBody [julius|
app.userR = "@{UserR unamep}";
app.dat.note = #{ toJSON note } || [];
app.dat.isowner = #{ isowner };
|]
toWidget [julius|
PS['Main'].renderNote('##{rawJS renderEl}')(app.dat.note)();
|]
getAddNoteSlimViewR :: Handler Html
getAddNoteSlimViewR = do
Entity userId user <- requireAuth
getAddNoteViewR (UserNameP (userName user))
getAddNoteViewR :: UserNameP -> Handler Html
getAddNoteViewR unamep@(UserNameP uname) = do
userId <- requireAuthId
note <- liftIO . _toNote userId =<< noteFormUrl
let renderEl = "note" :: Text
enote = Entity (NoteKey 0) note
defaultLayout do
$(widgetFile "note")
toWidgetBody [julius|
app.userR = "@{UserR unamep}";
app.noteR = "@{NoteR unamep (noteSlug (entityVal enote))}";
app.dat.note = #{ toJSON enote } || [];
|]
toWidget [julius|
PS['Main'].renderNote('##{rawJS renderEl}')(app.dat.note)();
|]
deleteDeleteNoteR :: Int64 -> Handler Html
deleteDeleteNoteR nid = do
userId <- requireAuthId
runDB do
let k_nid = NoteKey nid
_ <- requireResource userId k_nid
delete k_nid
return ""
postAddNoteR :: Handler Text
postAddNoteR = do
noteForm <- requireCheckJsonBody
_handleFormSuccess noteForm >>= \case
Created nid -> sendStatusJSON created201 nid
Updated _ -> sendResponseStatus noContent204 ()
Failed s -> sendResponseStatus status400 s
requireResource :: UserId -> Key Note -> DBM Handler Note
requireResource userId k_nid = do
nnote <- get404 k_nid
if userId == noteUserId nnote
then return nnote
else notFound
_handleFormSuccess :: NoteForm -> Handler (UpsertResult (Key Note))
_handleFormSuccess noteForm = do
userId <- requireAuthId
note <- liftIO $ _toNote userId noteForm
runDB (upsertNote userId knid note)
where
knid = NoteKey <$> (_id noteForm >>= \i -> if i > 0 then Just i else Nothing)
data NoteForm = NoteForm
{ _id :: Maybe Int64
, _slug :: Maybe NtSlug
, _title :: Maybe Text
, _text :: Maybe Textarea
, _isMarkdown :: Maybe Bool
, _shared :: Maybe Bool
, _created :: Maybe UTCTimeStr
, _updated :: Maybe UTCTimeStr
} deriving (Show, Eq, Read, Generic)
instance FromJSON NoteForm where parseJSON = A.genericParseJSON gNoteFormOptions
instance ToJSON NoteForm where toJSON = A.genericToJSON gNoteFormOptions
gNoteFormOptions :: A.Options
gNoteFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 }
noteFormUrl :: Handler NoteForm
noteFormUrl = do
title <- lookupGetParam "title"
description <- lookupGetParam "description" <&> fmap Textarea
isMarkdown <- lookupGetParam "isMarkdown" <&> fmap parseChk
pure $ NoteForm
{ _id = Nothing
, _slug = Nothing
, _title = title
, _text = description
, _isMarkdown = isMarkdown
, _shared = Nothing
, _created = Nothing
, _updated = Nothing
}
where
parseChk s = s == "yes" || s == "on" || s == "true" || s == "1"
_toNote :: UserId -> NoteForm -> IO Note
_toNote userId NoteForm {..} = do
time <- liftIO getCurrentTime
slug <- maybe mkNtSlug pure _slug
pure $
Note
{ noteUserId = userId
, noteSlug = slug
, noteLength = length _text
, noteTitle = fromMaybe "" _title
, noteText = maybe "" unTextarea _text
, noteIsMarkdown = Just True == _isMarkdown
, noteShared = Just True == _shared
, noteCreated = maybe time unUTCTimeStr _created
, noteUpdated = maybe time unUTCTimeStr _updated
}
noteToRssEntry :: UserNameP -> Entity Note -> FeedEntry (Route App)
noteToRssEntry usernamep (Entity entryId entry) =
FeedEntry
{ feedEntryLink = NoteR usernamep (noteSlug entry)
, feedEntryUpdated = noteUpdated entry
, feedEntryTitle = noteTitle entry
, feedEntryContent = toHtml (noteText entry)
, feedEntryEnclosure = Nothing
, feedEntryCategories = []
}
getNotesFeedR :: UserNameP -> Handler RepRss
getNotesFeedR unamep@(UserNameP uname) = do
mauthuname <- maybeAuthUsername
(limit', page') <- lookupPagingParams
mquery <- lookupGetParam "query"
let limit = maybe 20 fromIntegral limit'
page = maybe 1 fromIntegral page'
isowner = Just uname == mauthuname
(_, notes) <- runDB do
Entity userId user <- getBy404 (UniqueUserName uname)
when (not isowner && userPrivacyLock user)
(redirect (AuthR LoginR))
getNoteList userId mquery SharedPublic limit page
let (descr :: Html) = toHtml $ H.text (uname <> " notes")
entries = map (noteToRssEntry unamep) notes
updated <- case maximumMay (map feedEntryUpdated entries) of
Nothing -> liftIO getCurrentTime
Just m -> return m
rssFeed $
Feed
{ feedTitle = uname <> " notes"
, feedLinkSelf = NotesFeedR unamep
, feedLinkHome = NotesR unamep
, feedAuthor = uname
, feedDescription = descr
, feedLanguage = "en"
, feedUpdated = updated
, feedLogo = Nothing
, feedEntries = entries
}