/
User.hs
174 lines (158 loc) · 6.4 KB
/
User.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
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-# LANGUAGE TupleSections #-}
module Handler.User where
import qualified Data.Text as T
import Handler.Common
import Import
import qualified Text.Blaze.Html5 as H
import Yesod.RssFeed
import qualified Data.Map as Map
import qualified Network.Wai.Internal as W
getUserR :: UserNameP -> Handler Html
getUserR uname=
_getUser uname SharedAll FilterAll (TagsP [])
getUserSharedR :: UserNameP -> SharedP -> Handler Html
getUserSharedR uname sharedp =
_getUser uname sharedp FilterAll (TagsP [])
getUserFilterR :: UserNameP -> FilterP -> Handler Html
getUserFilterR uname filterp =
_getUser uname SharedAll filterp (TagsP [])
getUserTagsR :: UserNameP -> TagsP -> Handler Html
getUserTagsR uname = _getUser uname SharedAll FilterAll
_getUser :: UserNameP -> SharedP -> FilterP -> TagsP -> Handler Html
_getUser unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do
mauthuname <- maybeAuthUsername
(limit', page') <- lookupPagingParams
let limit = maybe 120 fromIntegral limit'
page = maybe 1 fromIntegral page'
isowner = Just uname == mauthuname
sharedp = if isowner then sharedp' else SharedPublic
filterp = case filterp' of
FilterSingle _ -> filterp'
_ -> if isowner then filterp' else FilterAll
isAll = filterp == FilterAll && sharedp == SharedAll && null pathtags
queryp = "query" :: Text
mquery <- lookupGetParam queryp
let mqueryp = fmap (queryp,) mquery
(bcount, btmarks) <- runDB $ do
Entity userId user <- getBy404 (UniqueUserName uname)
when (not isowner && userPrivacyLock user)
(redirect (AuthR LoginR))
bookmarksTagsQuery userId sharedp filterp pathtags mquery limit page
when (bcount == 0) (case filterp of FilterSingle _ -> notFound; _ -> pure ())
mroute <- getCurrentRoute
tagCloudMode <- getTagCloudMode isowner pathtags
req <- getRequest
defaultLayout do
let pager = $(widgetFile "pager")
search = $(widgetFile "search")
renderEl = "bookmarks" :: Text
tagCloudRenderEl = "tagCloud" :: Text
rssLink (UserFeedR unamep) "feed"
$(widgetFile "user")
toWidgetBody [julius|
app.dat.bmarks = #{ toJSON $ toBookmarkFormList btmarks } || [];
app.dat.isowner = #{ isowner };
app.userR = "@{UserR unamep}";
app.tagCloudMode = #{ toJSON $ tagCloudMode } || {};
|]
toWidget [hamlet|
<script type="module">
import { renderBookmarks, renderTagCloud } from '@{StaticR js_dist_Bookmarks_index_js}'
setTimeout(() => {
renderBookmarks('##{renderEl}')(app.dat.bmarks)();
}, 0);
setTimeout(() => {
renderTagCloud('##{tagCloudRenderEl}')(app.tagCloudMode)();
}, 0);
|]
-- Form
postUserTagCloudR :: Handler ()
postUserTagCloudR = do
userId <- requireAuthId
mode <- requireCheckJsonBody
_updateTagCloudMode mode
tc <- runDB $ case mode of
TagCloudModeTop _ n -> tagCountTop userId n
TagCloudModeLowerBound _ n -> tagCountLowerBound userId n
TagCloudModeRelated _ tags -> tagCountRelated userId tags
TagCloudModeNone -> notFound
sendStatusJSON ok200 (Map.fromList tc :: Map.Map Text Int)
postUserTagCloudModeR :: Handler ()
postUserTagCloudModeR = do
userId <- requireAuthId
mode <- requireCheckJsonBody
_updateTagCloudMode mode
_updateTagCloudMode :: TagCloudMode -> Handler ()
_updateTagCloudMode mode =
case mode of
TagCloudModeTop _ _ -> setTagCloudMode mode
TagCloudModeLowerBound _ _ -> setTagCloudMode mode
TagCloudModeRelated _ _ -> setTagCloudMode mode
TagCloudModeNone -> notFound
bookmarkToRssEntry :: (Entity Bookmark, Maybe Text) -> FeedEntry Text
bookmarkToRssEntry (Entity entryId entry, tags) =
FeedEntry
{ feedEntryLink = bookmarkHref entry
, feedEntryUpdated = bookmarkTime entry
, feedEntryTitle = bookmarkDescription entry
, feedEntryContent = toHtml (bookmarkExtended entry)
, feedEntryCategories = map (EntryCategory Nothing Nothing) (maybe [] words tags)
, feedEntryEnclosure = Nothing
}
getUserFeedR :: UserNameP -> Handler RepRss
getUserFeedR unamep = do
_getUserFeed unamep SharedAll FilterAll (TagsP [])
getUserFeedSharedR :: UserNameP -> SharedP -> Handler RepRss
getUserFeedSharedR uname sharedp =
_getUserFeed uname sharedp FilterAll (TagsP [])
getUserFeedFilterR :: UserNameP -> FilterP -> Handler RepRss
getUserFeedFilterR uname filterp =
_getUserFeed uname SharedAll filterp (TagsP [])
getUserFeedTagsR :: UserNameP -> TagsP -> Handler RepRss
getUserFeedTagsR uname = _getUserFeed uname SharedAll FilterAll
_getUserFeed :: UserNameP -> SharedP -> FilterP -> TagsP -> Handler RepRss
_getUserFeed unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do
mauthuname <- maybeAuthUsername
(limit', page') <- lookupPagingParams
let limit = maybe 120 fromIntegral limit'
page = maybe 1 fromIntegral page'
isowner = Just uname == mauthuname
sharedp = if isowner then sharedp' else SharedPublic
filterp = case filterp' of
FilterSingle _ -> filterp'
_ -> if isowner then filterp' else FilterAll
-- isAll = filterp == FilterAll && sharedp == SharedAll && null pathtags
queryp = "query" :: Text
mquery <- lookupGetParam queryp
(_, btmarks) <- runDB $ do
Entity userId user <- getBy404 (UniqueUserName uname)
when (not isowner && userPrivacyLock user)
(redirect (AuthR LoginR))
bookmarksTagsQuery userId sharedp filterp pathtags mquery limit page
let (descr :: Html) = toHtml $ H.text ("Bookmarks saved by " <> uname)
entries = map bookmarkToRssEntry btmarks
updated <- case maximumMay (map feedEntryUpdated entries) of
Nothing -> liftIO getCurrentTime
Just m -> return m
(feedLinkSelf, feedLinkHome) <- getFeedLinkSelf
rssFeedText $
Feed
{ feedTitle = "espial " <> uname
, feedLinkSelf = feedLinkSelf
, feedLinkHome = feedLinkHome
, feedAuthor = uname
, feedDescription = descr
, feedLanguage = "en"
, feedUpdated = updated
, feedLogo = Nothing
, feedEntries = entries
}
where
getFeedLinkSelf = do
request <- getRequest
render <- getUrlRender
let rawRequest = reqWaiRequest request
feedLinkSelf = render HomeR <> (T.drop 1 (decodeUtf8 (W.rawPathInfo rawRequest <> W.rawQueryString rawRequest)))
feedLinkHome = render (UserR unamep)
pure (feedLinkSelf, feedLinkHome)