Skip to content
Permalink
Browse files
disallow non http/https schemes for bookmark urls
  • Loading branch information
jonschoning committed Sep 30, 2021
1 parent 9e53a09 commit 2d3b3c3831bb0ac8972a736e448f67d731c50cba
Showing with 69 additions and 49 deletions.
  1. +2 −2 purs/src/App.purs
  2. +24 −15 purs/src/Component/Add.purs
  3. +16 −12 src/Handler/Add.hs
  4. +5 −4 src/Handler/Notes.hs
  5. +20 −14 src/Model.hs
  6. +1 −1 static/js/app.min.js
  7. BIN static/js/app.min.js.gz
  8. +1 −1 static/js/app.min.js.map
  9. BIN static/js/app.min.js.map.gz
@@ -44,9 +44,9 @@ markRead bid = do
let path = "bm/" <> show bid <> "/read"
fetchUrlEnc POST path Nothing AXRes.ignore

editBookmark :: Bookmark -> Aff (Either Error (Response Unit))
editBookmark :: Bookmark -> Aff (Either Error (Response String))
editBookmark bm = do
fetchJson POST "api/add" (Just (Bookmark' bm)) AXRes.ignore
fetchJson POST "api/add" (Just (Bookmark' bm)) AXRes.string

editNote :: Note -> Aff (Either Error (Response Json))
editNote bm = do
@@ -2,14 +2,18 @@ module Component.Add where

import Prelude hiding (div)

import Affjax (printError)
import Affjax.StatusCode (StatusCode(..))
import App (destroy, editBookmark, lookupTitle)
import Data.Either (Either(..))
import Data.Lens (Lens', lens, use, (%=), (.=))
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Monoid (guard)
import Data.String (Pattern(..), null, stripPrefix)
import Data.Tuple (fst, snd)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Console (log)
import Globals (app', closeWindow, mmoment8601)
import Halogen as H
import Halogen.HTML (button, div, form, input, label, p, span, table, tbody_, td, td_, text, textarea, tr_)
@@ -180,19 +184,24 @@ addbmark b' =
Etoread e -> _ { toread = e }

handleAction (BEditSubmit e) = do
H.liftEffect (preventDefault e)
liftEffect (preventDefault e)
edit_bm <- use _edit_bm
void $ H.liftAff (editBookmark edit_bm)
_bm .= edit_bm
qs <- liftEffect $ _curQuerystring
doc <- liftEffect $ _doc
ref <- liftEffect $ referrer doc
loc <- liftEffect $ _loc
org <- liftEffect $ origin loc
case _lookupQueryStringValue qs "next" of
Just "closeWindow" -> liftEffect $ closeWindow =<< window
Just "back" -> liftEffect $
if isJust (stripPrefix (Pattern org) ref)
then setHref ref loc
else setHref org loc
_ -> liftEffect $ closeWindow =<< window
H.liftAff (editBookmark edit_bm) >>= case _ of
Left affErr -> do
liftEffect $ log (printError affErr)
Right { status: StatusCode s } | s >= 200 && s < 300 -> do
_bm .= edit_bm
qs <- liftEffect $ _curQuerystring
doc <- liftEffect $ _doc
ref <- liftEffect $ referrer doc
loc <- liftEffect $ _loc
org <- liftEffect $ origin loc
case _lookupQueryStringValue qs "next" of
Just "closeWindow" -> liftEffect $ closeWindow =<< window
Just "back" -> liftEffect $
case stripPrefix (Pattern org) ref of
Just _ -> setHref ref loc
Nothing -> setHref org loc
_ -> liftEffect $ closeWindow =<< window
Right res -> do
liftEffect $ log (res.body)
@@ -57,24 +57,28 @@ bookmarkFormUrl = do

-- API

postAddR :: Handler ()
postAddR :: Handler Text
postAddR = do
bookmarkForm <- requireCheckJsonBody
_handleFormSuccess bookmarkForm >>= \case
(Created, bid) -> sendStatusJSON created201 bid
(Updated, _) -> sendResponseStatus noContent204 ()
Created bid -> sendStatusJSON created201 bid
Updated _ -> sendResponseStatus noContent204 ()
Failed s -> sendResponseStatus status400 s

_handleFormSuccess :: BookmarkForm -> Handler (UpsertResult, Key Bookmark)
_handleFormSuccess :: BookmarkForm -> Handler (UpsertResult (Key Bookmark))
_handleFormSuccess bookmarkForm = do
(userId, user) <- requireAuthPair
bm <- liftIO $ _toBookmark userId bookmarkForm
(res, kbid) <- runDB (upsertBookmark userId mkbid bm tags)
whenM (shouldArchiveBookmark user kbid) $
void $ async (archiveBookmarkUrl kbid (unpack (bookmarkHref bm)))
pure (res, kbid)
where
mkbid = BookmarkKey <$> _bid bookmarkForm
tags = maybe [] (nub . words . T.replace "," " ") (_tags bookmarkForm)
case (parseRequest . unpack . _url) bookmarkForm of
Nothing -> pure $ Failed "Invalid URL"
Just _ -> do
let mkbid = BookmarkKey <$> _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
@@ -97,12 +97,13 @@ deleteDeleteNoteR nid = do
delete k_nid
return ""

postAddNoteR :: Handler ()
postAddNoteR :: Handler Text
postAddNoteR = do
noteForm <- requireCheckJsonBody
_handleFormSuccess noteForm >>= \case
(Created, nid) -> sendStatusJSON created201 nid
(Updated, _) -> sendResponseStatus noContent204 ()
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
@@ -111,7 +112,7 @@ requireResource userId k_nid = do
then return nnote
else notFound

_handleFormSuccess :: NoteForm -> Handler (UpsertResult, Key Note)
_handleFormSuccess :: NoteForm -> Handler (UpsertResult (Key Note))
_handleFormSuccess noteForm = do
userId <- requireAuthId
note <- liftIO $ _toNote userId noteForm
@@ -1,3 +1,4 @@
{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

module Model where
@@ -693,23 +694,28 @@ fetchBookmarkByUrl userId murl = runMaybeT do
btags <- lift $ withTags (entityKey bmark)
pure (bmark, btags)

data UpsertResult = Created | Updated
data UpsertResult a = Created a | Updated a | Failed String
deriving (Show, Eq, Functor)

upsertBookmark :: Key User -> Maybe (Key Bookmark) -> Bookmark -> [Text] -> DB (UpsertResult, Key Bookmark)
maybeUpsertResult :: UpsertResult a -> Maybe a
maybeUpsertResult (Created a) = Just a
maybeUpsertResult (Updated a) = Just a
maybeUpsertResult _ = Nothing

upsertBookmark :: Key User -> Maybe (Key Bookmark) -> Bookmark -> [Text] -> DB (UpsertResult (Key Bookmark))
upsertBookmark userId mbid bm tags = do
res <- case mbid of
Just bid ->
get bid >>= \case
Just prev_bm -> do
when (userId /= bookmarkUserId prev_bm)
(throwString "unauthorized")
replaceBookmark bid prev_bm
_ -> throwString "not found"
Just prev_bm | userId == bookmarkUserId prev_bm ->
replaceBookmark bid prev_bm
Just _ -> pure (Failed "unauthorized")
_ -> pure (Failed "not found")
Nothing ->
getBy (UniqueUserHref (bookmarkUserId bm) (bookmarkHref bm)) >>= \case
Just (Entity bid prev_bm) -> replaceBookmark bid prev_bm
_ -> (Created,) <$> insert bm
insertTags (bookmarkUserId bm) (snd res)
Just (Entity bid prev_bm) -> replaceBookmark bid prev_bm
_ -> Created <$> insert bm
forM_ (maybeUpsertResult res) (insertTags (bookmarkUserId bm))
pure res
where
prepareReplace prev_bm =
@@ -719,7 +725,7 @@ upsertBookmark userId mbid bm tags = do
replaceBookmark bid prev_bm = do
replace bid (prepareReplace prev_bm)
deleteTags bid
pure (Updated, bid)
pure (Updated bid)
deleteTags bid =
deleteWhere [BookmarkTagBookmarkId CP.==. bid]
insertTags userId' bid' =
@@ -732,7 +738,7 @@ updateBookmarkArchiveUrl userId bid marchiveUrl =
[BookmarkUserId CP.==. userId, BookmarkId CP.==. bid]
[BookmarkArchiveHref CP.=. marchiveUrl]

upsertNote :: Key User -> Maybe (Key Note) -> Note -> DB (UpsertResult, Key Note)
upsertNote :: Key User -> Maybe (Key Note) -> Note -> DB (UpsertResult (Key Note))
upsertNote userId mnid note =
case mnid of
Just nid -> do
@@ -741,10 +747,10 @@ upsertNote userId mnid note =
when (userId /= noteUserId note')
(throwString "unauthorized")
replace nid note
pure (Updated, nid)
pure (Updated nid)
_ -> throwString "not found"
Nothing -> do
(Created,) <$> insert note
Created <$> insert note

-- * FileBookmarks

Large diffs are not rendered by default.

BIN +524 Bytes (100%) static/js/app.min.js.gz
Binary file not shown.

Large diffs are not rendered by default.

BIN +1.58 KB (100%) static/js/app.min.js.map.gz
Binary file not shown.

0 comments on commit 2d3b3c3

Please sign in to comment.