2019-01-31 02:54:47 +00:00
|
|
|
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
|
|
|
|
module Handler.Notes where
|
|
|
|
|
|
|
|
import Import
|
|
|
|
import Handler.Common (lookupPagingParams)
|
|
|
|
import qualified Data.Aeson as A
|
|
|
|
import qualified Data.Text as T
|
2019-09-15 09:51:20 +00:00
|
|
|
import Yesod.RssFeed
|
|
|
|
import Text.Blaze.Html (toHtml)
|
|
|
|
import qualified Text.Blaze.Html5 as H
|
2019-01-31 02:54:47 +00:00
|
|
|
|
|
|
|
getNotesR :: UserNameP -> Handler Html
|
|
|
|
getNotesR unamep@(UserNameP uname) = do
|
2019-09-15 22:30:18 +00:00
|
|
|
mauthuname <- maybeAuthUsername
|
2019-01-31 02:54:47 +00:00
|
|
|
(limit', page') <- lookupPagingParams
|
2019-09-15 22:30:18 +00:00
|
|
|
let queryp = "query"
|
2019-01-31 02:54:47 +00:00
|
|
|
mquery <- lookupGetParam queryp
|
|
|
|
let limit = maybe 20 fromIntegral limit'
|
2019-09-15 22:30:18 +00:00
|
|
|
page = maybe 1 fromIntegral page'
|
2019-09-15 09:51:20 +00:00
|
|
|
mqueryp = fmap (\q -> (queryp, q)) mquery
|
2019-09-15 22:30:18 +00:00
|
|
|
isowner = maybe False (== uname) mauthuname
|
2019-09-15 09:51:20 +00:00
|
|
|
(bcount, notes) <- runDB $ do
|
2019-09-15 22:30:18 +00:00
|
|
|
Entity userId user <- getBy404 (UniqueUserName uname)
|
|
|
|
let sharedp = if isowner then SharedAll else SharedPublic
|
|
|
|
when (not isowner && userPrivacyLock user)
|
|
|
|
(redirect (AuthR LoginR))
|
2019-09-15 13:43:03 +00:00
|
|
|
getNoteList userId mquery sharedp limit page
|
2019-01-31 02:54:47 +00:00
|
|
|
req <- getRequest
|
2019-09-15 09:51:20 +00:00
|
|
|
mroute <- getCurrentRoute
|
2019-01-31 02:54:47 +00:00
|
|
|
defaultLayout $ do
|
2019-09-15 09:51:20 +00:00
|
|
|
rssLink (NotesFeedR unamep) "feed"
|
2019-01-31 02:54:47 +00:00
|
|
|
let pager = $(widgetFile "pager")
|
|
|
|
search = $(widgetFile "search")
|
|
|
|
renderEl = "notes" :: Text
|
|
|
|
$(widgetFile "notes")
|
|
|
|
toWidgetBody [julius|
|
|
|
|
app.userR = "@{UserR unamep}";
|
2019-09-15 09:51:20 +00:00
|
|
|
app.dat.notes = #{ toJSON notes } || [];
|
2019-09-15 23:13:07 +00:00
|
|
|
app.dat.isowner = #{ isowner };
|
2019-01-31 02:54:47 +00:00
|
|
|
|]
|
|
|
|
toWidget [julius|
|
|
|
|
PS['Main'].renderNotes('##{rawJS renderEl}')(app.dat.notes)();
|
|
|
|
|]
|
|
|
|
|
|
|
|
getNoteR :: UserNameP -> NtSlug -> Handler Html
|
|
|
|
getNoteR unamep@(UserNameP uname) slug = do
|
2019-09-15 22:30:18 +00:00
|
|
|
mauthuname <- maybeAuthUsername
|
2019-01-31 02:54:47 +00:00
|
|
|
let renderEl = "note" :: Text
|
2019-09-15 22:30:18 +00:00
|
|
|
isowner = maybe False (== uname) mauthuname
|
2019-01-31 02:54:47 +00:00
|
|
|
note <-
|
|
|
|
runDB $
|
2019-09-15 22:30:18 +00:00
|
|
|
do Entity userId user <- getBy404 (UniqueUserName uname)
|
2019-01-31 02:54:47 +00:00
|
|
|
mnote <- getNote userId slug
|
2019-09-15 22:30:18 +00:00
|
|
|
note <- maybe notFound pure mnote
|
|
|
|
when (not isowner && (userPrivacyLock user || (not . noteShared . entityVal) note))
|
|
|
|
(redirect (AuthR LoginR))
|
|
|
|
pure note
|
2019-01-31 02:54:47 +00:00
|
|
|
defaultLayout $ do
|
|
|
|
$(widgetFile "note")
|
|
|
|
toWidgetBody [julius|
|
|
|
|
app.userR = "@{UserR unamep}";
|
2019-09-15 09:51:20 +00:00
|
|
|
app.dat.note = #{ toJSON note } || [];
|
2019-09-15 23:13:07 +00:00
|
|
|
app.dat.isowner = #{ isowner };
|
2019-01-31 02:54:47 +00:00
|
|
|
|]
|
|
|
|
toWidget [julius|
|
|
|
|
PS['Main'].renderNote('##{rawJS renderEl}')(app.dat.note)();
|
|
|
|
|]
|
|
|
|
|
|
|
|
getAddNoteViewR :: UserNameP -> Handler Html
|
|
|
|
getAddNoteViewR unamep@(UserNameP uname) = do
|
|
|
|
userId <- requireAuthId
|
|
|
|
let renderEl = "note" :: Text
|
2019-09-15 13:43:03 +00:00
|
|
|
note <- liftIO $ Entity (NoteKey 0) <$> _toNote userId (NoteForm Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
|
2019-01-31 02:54:47 +00:00
|
|
|
defaultLayout $ do
|
|
|
|
$(widgetFile "note")
|
|
|
|
toWidgetBody [julius|
|
|
|
|
app.userR = "@{UserR unamep}";
|
|
|
|
app.noteR = "@{NoteR unamep (noteSlug (entityVal note))}";
|
2019-09-15 09:51:20 +00:00
|
|
|
app.dat.note = #{ toJSON note } || [];
|
2019-01-31 02:54:47 +00:00
|
|
|
|]
|
|
|
|
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
|
|
|
|
deleteCascade k_nid
|
|
|
|
return ""
|
|
|
|
|
|
|
|
postAddNoteR :: Handler ()
|
|
|
|
postAddNoteR = do
|
|
|
|
noteForm <- requireCheckJsonBody
|
|
|
|
_handleFormSuccess noteForm >>= \case
|
|
|
|
(Created, nid) -> sendStatusJSON created201 nid
|
|
|
|
(Updated, _) -> sendResponseStatus noContent204 ()
|
|
|
|
|
|
|
|
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
|
2019-09-15 23:13:07 +00:00
|
|
|
runDB (upsertNote userId knid note)
|
2019-01-31 02:54:47 +00:00
|
|
|
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
|
2019-09-15 13:43:03 +00:00
|
|
|
, _shared :: Maybe Bool
|
2019-01-31 02:54:47 +00:00
|
|
|
, _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
|
2019-09-15 09:51:20 +00:00
|
|
|
gNoteFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 }
|
2019-01-31 02:54:47 +00:00
|
|
|
|
|
|
|
_toNote :: UserId -> NoteForm -> IO Note
|
|
|
|
_toNote userId NoteForm {..} = do
|
|
|
|
time <- liftIO getCurrentTime
|
|
|
|
slug <- maybe mkNtSlug pure _slug
|
|
|
|
pure $
|
|
|
|
Note
|
|
|
|
userId
|
|
|
|
slug
|
|
|
|
(length _text)
|
|
|
|
(fromMaybe "" _title)
|
|
|
|
(maybe "" unTextarea _text)
|
|
|
|
(fromMaybe False _isMarkdown)
|
2019-09-15 13:43:03 +00:00
|
|
|
(fromMaybe False _shared)
|
2019-01-31 02:54:47 +00:00
|
|
|
(fromMaybe time (fmap unUTCTimeStr _created))
|
|
|
|
(fromMaybe time (fmap unUTCTimeStr _updated))
|
2019-09-15 09:51:20 +00:00
|
|
|
|
|
|
|
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
|
|
|
|
}
|
|
|
|
|
|
|
|
getNotesFeedR :: UserNameP -> Handler RepRss
|
|
|
|
getNotesFeedR unamep@(UserNameP uname) = do
|
2019-09-15 22:30:18 +00:00
|
|
|
mauthuname <- maybeAuthUsername
|
2019-09-15 09:51:20 +00:00
|
|
|
(limit', page') <- lookupPagingParams
|
2019-09-15 22:30:18 +00:00
|
|
|
mquery <- lookupGetParam "query"
|
2019-09-15 09:51:20 +00:00
|
|
|
let limit = maybe 20 fromIntegral limit'
|
|
|
|
page = maybe 1 fromIntegral page'
|
2019-09-15 22:30:18 +00:00
|
|
|
isowner = maybe False (== uname) mauthuname
|
|
|
|
(_, notes) <- runDB $ do
|
|
|
|
Entity userId user <- getBy404 (UniqueUserName uname)
|
|
|
|
when (not isowner && userPrivacyLock user)
|
|
|
|
(redirect (AuthR LoginR))
|
2019-09-15 13:43:03 +00:00
|
|
|
getNoteList userId mquery SharedPublic limit page
|
2019-09-15 09:51:20 +00:00
|
|
|
let (descr :: Html) = toHtml $ H.text (uname <> " notes")
|
2019-09-15 22:30:18 +00:00
|
|
|
entries = map (noteToRssEntry unamep) notes
|
2019-09-15 09:51:20 +00:00
|
|
|
updated <- case maximumMay (map feedEntryUpdated entries) of
|
|
|
|
Nothing -> liftIO $ getCurrentTime
|
|
|
|
Just m -> return m
|
|
|
|
rssFeed $ Feed (uname <> " notes")
|
|
|
|
(NotesFeedR unamep)
|
|
|
|
(NotesR unamep)
|
|
|
|
uname
|
|
|
|
descr
|
|
|
|
"en"
|
|
|
|
updated
|
|
|
|
Nothing
|
|
|
|
entries
|