disallow non http/https schemes for bookmark urls

purs/src/App.purs

@@ -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

purs/src/Component/Add.purs

@@ -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)

src/Handler/Add.hs

@@ -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

src/Handler/Notes.hs

@@ -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

src/Model.hs

@@ -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