Ability to fetch the title of the link #8

config/routes

@@ -31,6 +31,7 @@ api/accountSettings EditAccountSettingsR POST
 -- add
 /add AddViewR GET
 api/add AddR POST
+api/lookuptitle LookupTitleR POST
 
 -- edit
 /bm/#Int64 DeleteR DELETE

purs/Makefile

@@ -1,12 +1,14 @@
 .PHONY: clean build
 
-all: build
+all: bundle
 
 install: 
-	spago install
+	@spago install
 
 build: 
 	@spago build
+
+bundle: build
 	@spago bundle-app --to dist/bundle.js
 	@npm run parcel-build
 	@rm -f dist/*.gz
@@ -27,4 +29,4 @@ docset: docs
 clean:
 	rm -f dist/*
 
-# inotifywait -m -r -q -e close_write --format '%T %w%f' --timefmt '%T' src | while read FILE; do echo $FILE; make; done
+# inotifywait -m -r -q -e close_write --format '%T %w%f' --timefmt '%T' src | while read FILE; do echo $FILE; make build; done

purs/package.json

@@ -7,12 +7,12 @@
     "parcel-build": "parcel build dist/bundle.js --out-file dist/app.min.js --public-url /static/js/"
   },
   "devDependencies": {
-    "purescript": "^0.13.3",
-    "spago": "^0.10.0",
     "marked": "^0.7.0",
     "moment": "^2.24.0",
-    "parcel-bundler": "^1.12.3",
-    "terser": "^4.0.0"
+    "parcel-bundler": "^1.12.4",
+    "purescript": "^0.13.3",
+    "spago": "^0.10.0",
+    "terser": "^4.6.3"
   },
   "dependencies": {}
 }

purs/src/App.purs

@@ -8,9 +8,10 @@ import Affjax as Ax
 import Affjax.RequestBody as AXReq
 import Affjax.RequestHeader (RequestHeader(..))
 import Affjax.ResponseFormat as AXRes
+import Affjax.StatusCode (StatusCode(..))
 import Data.Argonaut (Json)
 import Data.Array ((:))
-import Data.Either (Either(..))
+import Data.Either (Either(..), hush)
 import Data.FormURLEncoded (FormURLEncoded)
 import Data.HTTP.Method (Method(..))
 import Data.Maybe (Maybe(..))
@@ -51,6 +52,14 @@ editNote :: Note -> Aff (Either Error (Response Json))
 editNote bm =  do
     fetchJson POST "api/note/add" (Just (Note' bm)) AXRes.json
 
+lookupTitle :: Bookmark -> Aff (Maybe String)
+lookupTitle bm = do
+  eres <- fetchJson POST "api/lookuptitle" (Just (Bookmark' bm)) AXRes.string
+  pure $ hush eres >>= \res ->
+    if (res.status == StatusCode 200)
+    then Just res.body
+    else Nothing
+      
 destroyNote :: Int -> Aff (Either Error (Response Unit))
 destroyNote nid =  do
   fetchUrlEnc DELETE ("api/note/" <> show nid) Nothing AXRes.ignore

purs/src/Component/Add.purs

@@ -1,8 +1,9 @@
 module Component.Add where
 
+
 import Prelude hiding (div)
 
-import App (destroy, editBookmark)
+import App (destroy, editBookmark, lookupTitle)
 import Data.Array (drop, foldMap)
 import Data.Lens (Lens', lens, use, (%=), (.=))
 import Data.Maybe (Maybe(..), maybe)
@@ -17,7 +18,7 @@ import Globals (app', closeWindow, mmoment8601)
 import Halogen as H
 import Halogen.HTML (HTML, br_, button, div, form, input, label, p, span, table, tbody_, td, td_, text, textarea, tr_)
 import Halogen.HTML.Events (onSubmit, onValueChange, onChecked, onClick)
-import Halogen.HTML.Properties (autofocus, ButtonType(..), InputType(..), autocomplete, checked, for, id_, name, required, rows, title, type_, value)
+import Halogen.HTML.Properties (ButtonType(..), InputType(..), autocomplete, autofocus, checked, disabled, for, id_, name, required, rows, title, type_, value)
 import Model (Bookmark)
 import Util (_curQuerystring, _loc, _lookupQueryStringValue, attr, class_, ifElseH, whenH)
 import Web.Event.Event (Event, preventDefault)
@@ -28,6 +29,7 @@ data BAction
   = BEditField EditField
   | BEditSubmit Event
   | BDeleteAsk Boolean
+  | BLookupTitle
   | BDestroy
 
 data EditField
@@ -42,6 +44,7 @@ type BState =
   { bm :: Bookmark
   , edit_bm :: Bookmark
   , deleteAsk :: Boolean
+  , loading :: Boolean
   , destroyed :: Boolean
   }
 
@@ -66,6 +69,7 @@ addbmark b' =
     , edit_bm: b
     , deleteAsk: false
     , destroyed: false
+    , loading: false
     }
 
   render :: forall m. BState -> H.ComponentHTML BAction () m
@@ -87,12 +91,14 @@ addbmark b' =
            , tr_
              [ td_ [ label [ for "url" ] [ text "URL" ] ]
              , td_ [ input [ type_ InputUrl , id_ "url", class_ "w-100 mv1" , required true, name "url", autofocus (null bm.url)
-                           , value (edit_bm.url) , onValueChange (editField Eurl)] ]
+                          , value (edit_bm.url) , onValueChange (editField Eurl)] ]
              ]
            , tr_
              [ td_ [ label [ for "title" ] [ text "title" ] ]
-             , td_ [ input [ type_ InputText , id_ "title", class_ "w-100 mv1" , name "title"
-                           , value (edit_bm.title) , onValueChange (editField Etitle)] ]
+             , td [class_ "flex"]
+                  [ input [ type_ InputText , id_ "title", class_ "w-100 mv1 flex-auto" , name "title" , value (edit_bm.title) , onValueChange (editField Etitle)]
+                  , button [ disabled s.loading, type_ ButtonButton, onClick \_ -> Just BLookupTitle, class_ ("ml2 input-reset ba b--navy pointer f6 di dim pa1 ma1 mr0 " <> guard s.loading "bg-light-silver") ] [ text "Fetch" ]
+                  ]
              ]
            , tr_
              [ td_ [ label [ for "description" ] [ text "description" ] ]
@@ -152,6 +158,14 @@ addbmark b' =
   handleAction :: BAction -> H.HalogenM BState BAction () o Aff Unit
   handleAction (BDeleteAsk e) = do
     H.modify_ (_ { deleteAsk = e })
+  handleAction BLookupTitle = do
+    H.modify_ (_ { loading = true })
+    edit_bm <- H.gets _.edit_bm
+    mtitle <- H.liftAff $ lookupTitle edit_bm
+    case mtitle of
+      Just title' -> _edit_bm %= (_ { title = title' })
+      Nothing -> pure $ unit
+    H.modify_ (_ { loading = false })
   handleAction (BDestroy) = do
     bid <- H.gets _.bm.bid
     void $ H.liftAff (destroy bid)

purs/src/Component/BMark.purs

@@ -2,7 +2,7 @@ module Component.BMark where
 
 import Prelude hiding (div)
 
-import App (StarAction(..), destroy, editBookmark, markRead, toggleStar)
+import App (StarAction(..), destroy, editBookmark, markRead, toggleStar, lookupTitle)
 import Component.Markdown as Markdown
 import Data.Const (Const)
 import Data.Lens (Lens', lens, use, (%=), (.=))
@@ -18,7 +18,7 @@ import Halogen as H
 import Halogen.HTML (HTML, a, br_, button, div, div_, form, input, label, span, text, textarea)
 import Halogen.HTML as HH
 import Halogen.HTML.Events (onSubmit, onValueChange, onChecked, onClick)
-import Halogen.HTML.Properties (ButtonType(..), InputType(..), autocomplete, checked, for, href, id_, name, required, rows, target, title, type_, value)
+import Halogen.HTML.Properties (ButtonType(..), InputType(..), autocomplete, checked, disabled, for, href, id_, name, required, rows, target, title, type_, value)
 import Model (Bookmark)
 import Util (attr, class_, fromNullableStr, ifElseH, whenH, whenA)
 import Web.Event.Event (Event, preventDefault)
@@ -27,6 +27,7 @@ import Web.Event.Event (Event, preventDefault)
 data BAction
   = BStar Boolean
   | BDeleteAsk Boolean
+  | BLookupTitle
   | BDestroy
   | BEdit Boolean
   | BEditField EditField
@@ -53,6 +54,7 @@ type BState =
   , edit_bm :: Bookmark
   , deleteAsk:: Boolean
   , edit :: Boolean
+  , loading :: Boolean
   }
 
 _bm :: Lens' BState Bookmark
@@ -85,6 +87,7 @@ bmark b' =
     , edit_bm: b
     , deleteAsk: false
     , edit: false
+    , loading: false
     }
 
   render :: BState -> H.ComponentHTML BAction ChildSlots Aff
@@ -154,8 +157,11 @@ bmark b' =
                  , value (edit_bm.url) , onValueChange (editField Eurl) ]
          , br_
          , div_ [ text "title" ]
-         , input [ type_ InputText , class_ "title w-100 mb2 pt1 f7 edit_form_input" , name "title"
-                 , value (edit_bm.title) , onValueChange (editField Etitle) ]
+         , div [class_ "flex"]
+               [input [ type_ InputText , class_ "title w-100 mb2 pt1 f7 edit_form_input" , name "title"
+                      , value (edit_bm.title) , onValueChange (editField Etitle) ]
+               , button [ disabled s.loading, type_ ButtonButton, onClick \_ -> Just BLookupTitle, class_ ("ml1 pa1 mb2 dark-gray ba b--moon-gray bg-near-white pointer rdim f7 " <> guard s.loading "bg-light-silver") ] [ text "Fetch" ]
+               ]
          , br_
          , div_ [ text "description" ]
          , textarea [ class_ "description w-100 mb1 pt1 f7 edit_form_input" , name "description", rows 5
@@ -235,6 +241,16 @@ bmark b' =
       Eprivate e -> _ { private = e }
       Etoread e -> _ { toread = e }
 
+  -- | Lookup Title
+  handleAction BLookupTitle = do
+    H.modify_ (_ { loading = true })
+    edit_bm <- H.gets _.edit_bm
+    mtitle <- H.liftAff $ lookupTitle edit_bm
+    case mtitle of
+      Just title' -> _edit_bm %= (_ { title = title' })
+      Nothing -> pure $ unit
+    H.modify_ (_ { loading = false })
+
   -- | Submit
   handleAction (BEditSubmit e) = do
     H.liftEffect (preventDefault e)

src/Handler/Add.hs

@@ -65,3 +65,11 @@ _handleFormSuccess bookmarkForm = do
   where
     mkbid = BookmarkKey <$> _bid bookmarkForm
     tags = maybe [] (nub . words) (_tags bookmarkForm)
+
+postLookupTitleR :: Handler ()
+postLookupTitleR = do
+  void requireAuthId
+  bookmarkForm <- (requireCheckJsonBody :: Handler BookmarkForm)
+  fetchPageTitle (unpack (_url bookmarkForm)) >>= \case
+    Left _ -> sendResponseStatus noContent204 ()
+    Right title -> sendResponseStatus ok200 title

src/Handler/Archive.hs

@@ -85,16 +85,12 @@ _buildArchiveSubmitRequest (action, submitId) href =
 _fetchArchiveSubmitInfo :: Handler (Either String (String , String))
 _fetchArchiveSubmitInfo = do
   MM.increment "archive.fetchSubmitId"  
-  res <- liftIO $ NH.httpLbs buildSubmitRequest =<< NH.getGlobalManager
+  res <- liftIO $ NH.httpLbs (buildSimpleRequest "https://archive.li/") =<< NH.getGlobalManager
   MM.increment ("archive.fetchSubmitId_status_" <> (pack.show) (NH.statusCode (NH.responseStatus res))) 
   let body = LBS.toStrict (responseBody res)
       action = _parseSubstring (AP.string "action=\"") (AP.notChar '"') body
       submitId = _parseSubstring (AP.string "submitid\" value=\"") (AP.notChar '"') body
   pure $ (,) <$> action <*> submitId
-  where
-    buildSubmitRequest =
-      NH.parseRequest_ "https://archive.li/" & \r ->
-        r {NH.requestHeaders = [("User-Agent", _archiveUserAgent)]}
 
 _archiveUserAgent :: ByteString
 _archiveUserAgent = "espial"
@@ -104,3 +100,26 @@ _parseSubstring start inner res = do
   (flip AP.parseOnly) res (skipAnyTill start >> AP.many1 inner)
   where
     skipAnyTill end = go where go = end *> pure () <|> AP.anyChar *> go
+
+
+fetchPageTitle :: String -> Handler (Either String String)
+fetchPageTitle url = do
+  MM.increment "fetchPageTitle"  
+  res <- liftIO $ NH.httpLbs (buildSimpleRequest url) =<< NH.getGlobalManager
+  let body = LBS.toStrict (responseBody res)
+      title = (flip AP.parseOnly) body $ do
+                 _ <- skipAnyTill (AP.string "<title")
+                 _ <- skipAnyTill (AP.string ">")
+                 AP.many1 (AP.notChar '<')
+  pure title
+  `catch` (\(e::SomeException) -> do
+    MM.increment "fetchPageTitle.error"  
+    $(logError) $ (pack.show) e
+    pure (Left (show e)))
+  where
+    skipAnyTill end = go where go = end *> pure () <|> AP.anyChar *> go
+
+buildSimpleRequest :: String -> Request
+buildSimpleRequest url =
+  NH.parseRequest_ url & \r ->
+    r {NH.requestHeaders = [("User-Agent", _archiveUserAgent)]}