135 lines
4.1 KiB
Haskell
135 lines
4.1 KiB
Haskell
{-# 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
|
|
|
|
getNotesR :: UserNameP -> Handler Html
|
|
getNotesR unamep@(UserNameP uname) = do
|
|
void requireAuthId
|
|
(limit', page') <- lookupPagingParams
|
|
let queryp = "query" :: Text
|
|
mquery <- lookupGetParam queryp
|
|
let limit = maybe 20 fromIntegral limit'
|
|
page = maybe 1 fromIntegral page'
|
|
mqueryp = fmap (\q -> (queryp, q)) mquery
|
|
(bcount, notes) <-
|
|
runDB $
|
|
do Entity userId _ <- getBy404 (UniqueUserName uname)
|
|
getNoteList userId mquery limit page
|
|
req <- getRequest
|
|
mroute <- getCurrentRoute
|
|
defaultLayout $ do
|
|
let pager = $(widgetFile "pager")
|
|
search = $(widgetFile "search")
|
|
renderEl = "notes" :: Text
|
|
$(widgetFile "notes")
|
|
toWidgetBody [julius|
|
|
app.userR = "@{UserR unamep}";
|
|
app.dat.notes = #{ toJSON notes } || [];
|
|
|]
|
|
toWidget [julius|
|
|
PS['Main'].renderNotes('##{rawJS renderEl}')(app.dat.notes)();
|
|
|]
|
|
|
|
getNoteR :: UserNameP -> NtSlug -> Handler Html
|
|
getNoteR unamep@(UserNameP uname) slug = do
|
|
void requireAuthId
|
|
let renderEl = "note" :: Text
|
|
note <-
|
|
runDB $
|
|
do Entity userId _ <- getBy404 (UniqueUserName uname)
|
|
mnote <- getNote userId slug
|
|
maybe notFound pure mnote
|
|
defaultLayout $ do
|
|
addScript (StaticR js_marked_min_js)
|
|
$(widgetFile "note")
|
|
toWidgetBody [julius|
|
|
app.userR = "@{UserR unamep}";
|
|
app.dat.note = #{ toJSON note } || [];
|
|
|]
|
|
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
|
|
note <- liftIO $ Entity (NoteKey 0) <$> _toNote userId (NoteForm Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
|
|
defaultLayout $ do
|
|
addScript (StaticR js_marked_min_js)
|
|
$(widgetFile "note")
|
|
toWidgetBody [julius|
|
|
app.userR = "@{UserR unamep}";
|
|
app.noteR = "@{NoteR unamep (noteSlug (entityVal note))}";
|
|
app.dat.note = #{ toJSON note } || [];
|
|
|]
|
|
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
|
|
runDB (upsertNote 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
|
|
, _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 }
|
|
|
|
_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)
|
|
(fromMaybe time (fmap unUTCTimeStr _created))
|
|
(fromMaybe time (fmap unUTCTimeStr _updated))
|