From 85fa64979cbefc5ee275fbab93098bc82fdee0e4 Mon Sep 17 00:00:00 2001 From: Jon Schoning Date: Fri, 2 Oct 2020 11:09:10 -0500 Subject: [PATCH] convert CRLF to LF --- purs/src/Component/BList.purs | 78 +- purs/src/Component/BMark.purs | 524 +++---- purs/src/Globals.js | 136 +- purs/src/Globals.purs | 194 +-- purs/src/Main.purs | 150 +- purs/src/Util.purs | 296 ++-- src/Foundation.hs | 504 +++---- src/Handler/Add.hs | 168 +-- src/Handler/User.hs | 308 ++-- src/Model.hs | 1696 +++++++++++------------ src/PathPiece.hs | 110 +- static/css/main.css | 410 +++--- static/js/app.min.js.gz | Bin 80462 -> 80462 bytes static/js/app.min.js.map.gz | Bin 262783 -> 262783 bytes templates/default-layout-wrapper.hamlet | 76 +- templates/user.hamlet | 122 +- 16 files changed, 2386 insertions(+), 2386 deletions(-) diff --git a/purs/src/Component/BList.purs b/purs/src/Component/BList.purs index c5afab1..ccd8291 100644 --- a/purs/src/Component/BList.purs +++ b/purs/src/Component/BList.purs @@ -1,39 +1,39 @@ -module Component.BList where - -import Prelude - -import Component.BMark (BMessage(..), BSlot, bmark) -import Model (Bookmark, BookmarkId) - -import Data.Array (filter) -import Data.Maybe (Maybe(..)) -import Effect.Aff (Aff) -import Halogen as H -import Halogen.HTML as HH -import Data.Symbol (SProxy(..)) - -data LAction = - HandleBMessage BookmarkId BMessage - -type ChildSlots = - ( bookmark :: BSlot Int - ) - -_bookmark = SProxy :: SProxy "bookmark" - -blist :: forall q i o. Array Bookmark -> H.Component HH.HTML q i o Aff -blist st = - H.mkComponent - { initialState: const st - , render - , eval: H.mkEval $ H.defaultEval { handleAction = handleAction } - } - where - - render :: Array Bookmark -> H.ComponentHTML LAction ChildSlots Aff - render bms = - HH.div_ $ map (\b -> HH.slot _bookmark b.bid (bmark b) unit (Just <<< HandleBMessage b.bid)) bms - - handleAction :: LAction -> H.HalogenM (Array Bookmark) LAction ChildSlots o Aff Unit - handleAction (HandleBMessage bid BNotifyRemove) = do - H.modify_ (filter (\b -> b.bid /= bid)) +module Component.BList where + +import Prelude + +import Component.BMark (BMessage(..), BSlot, bmark) +import Model (Bookmark, BookmarkId) + +import Data.Array (filter) +import Data.Maybe (Maybe(..)) +import Effect.Aff (Aff) +import Halogen as H +import Halogen.HTML as HH +import Data.Symbol (SProxy(..)) + +data LAction = + HandleBMessage BookmarkId BMessage + +type ChildSlots = + ( bookmark :: BSlot Int + ) + +_bookmark = SProxy :: SProxy "bookmark" + +blist :: forall q i o. Array Bookmark -> H.Component HH.HTML q i o Aff +blist st = + H.mkComponent + { initialState: const st + , render + , eval: H.mkEval $ H.defaultEval { handleAction = handleAction } + } + where + + render :: Array Bookmark -> H.ComponentHTML LAction ChildSlots Aff + render bms = + HH.div_ $ map (\b -> HH.slot _bookmark b.bid (bmark b) unit (Just <<< HandleBMessage b.bid)) bms + + handleAction :: LAction -> H.HalogenM (Array Bookmark) LAction ChildSlots o Aff Unit + handleAction (HandleBMessage bid BNotifyRemove) = do + H.modify_ (filter (\b -> b.bid /= bid)) diff --git a/purs/src/Component/BMark.purs b/purs/src/Component/BMark.purs index 6b3e8bd..2de3067 100644 --- a/purs/src/Component/BMark.purs +++ b/purs/src/Component/BMark.purs @@ -1,262 +1,262 @@ -module Component.BMark where - -import Prelude hiding (div) - -import App (StarAction(..), destroy, editBookmark, markRead, toggleStar, lookupTitle) -import Component.Markdown as Markdown -import Data.Const (Const) -import Data.Lens (Lens', lens, use, (%=), (.=)) -import Data.Maybe (Maybe(..), fromMaybe, isJust) -import Data.Monoid (guard) -import Data.Nullable (toMaybe) -import Data.String (null, split, take, replaceAll) as S -import Data.String.Pattern (Pattern(..), Replacement(..)) -import Data.Symbol (SProxy(..)) -import Effect.Aff (Aff) -import Globals (app', setFocus, toLocaleDateString) -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, 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) - --- | UI Events -data BAction - = BStar Boolean - | BDeleteAsk Boolean - | BLookupTitle - | BDestroy - | BEdit Boolean - | BEditField EditField - | BEditSubmit Event - | BMarkRead - --- | FormField Edits -data EditField - = Eurl String - | Etitle String - | Edescription String - | Etags String - | Eprivate Boolean - | Etoread Boolean - --- | Messages to parent -data BMessage - = BNotifyRemove - -type BSlot = H.Slot (Const Void) BMessage - -type BState = - { bm :: Bookmark - , edit_bm :: Bookmark - , deleteAsk:: Boolean - , edit :: Boolean - , loading :: Boolean - } - -_bm :: Lens' BState Bookmark -_bm = lens _.bm (_ { bm = _ }) - -_edit_bm :: Lens' BState Bookmark -_edit_bm = lens _.edit_bm (_ { edit_bm = _ }) - -_edit :: Lens' BState Boolean -_edit = lens _.edit (_ { edit = _ }) - -_markdown = SProxy :: SProxy "markdown" - -type ChildSlots = - ( markdown :: Markdown.Slot Unit - ) - -bmark :: forall q i. Bookmark -> H.Component HTML q i BMessage Aff -bmark b' = - H.mkComponent - { initialState: const (mkState b') - , render - , eval: H.mkEval $ H.defaultEval { handleAction = handleAction } - } - where - app = app' unit - - mkState b = - { bm: b - , edit_bm: b - , deleteAsk: false - , edit: false - , loading: false - } - - render :: BState -> H.ComponentHTML BAction ChildSlots Aff - render s@{ bm, edit_bm } = - div [ id_ (show bm.bid) , class_ ("bookmark w-100 mw7 pa1 mb3" <> guard bm.private " private")] $ - [ whenH app.dat.isowner - star - , ifElseH s.edit - display_edit - display - ] - - where - - star _ = - div [ class_ ("star fl pointer" <> guard bm.selected " selected") ] - [ button [ class_ "moon-gray", onClick \_ -> Just (BStar (not bm.selected)) ] [ text "✭" ] ] - - display _ = - div [ class_ "display" ] $ - [ a [ href bm.url, target "_blank", class_ ("link f5 lh-title" <> guard bm.toread " unread")] - [ text $ if S.null bm.title then "[no title]" else bm.title ] - , br_ - , a [ href bm.url , class_ "link f7 gray hover-blue" ] [ text bm.url ] - , a [ href (fromMaybe ("http://archive.is/" <> bm.url) (toMaybe bm.archiveUrl)) - , class_ ("link f7 gray hover-blue ml2" <> (guard (isJust (toMaybe bm.archiveUrl)) " green")) - , target "_blank", title "archive link"] - [ if isJust (toMaybe bm.archiveUrl) then text "☑" else text "☐" ] - , br_ - , div [ class_ "description mt1 mid-gray" ] [ HH.slot _markdown unit Markdown.component bm.description absurd ] - , div [ class_ "tags" ] $ - whenA (not (S.null bm.tags)) $ \_ -> - map (\tag -> a [ class_ ("link tag mr1" <> guard (S.take 1 tag == ".") " private") - , href (linkToFilterTag tag) ] - [ text tag ]) - (S.split (Pattern " ") bm.tags) - - , a [ class_ "link f7 dib gray w4", href (linkToFilterSingle bm.slug), title shdatetime ] - [ text shdate ] - - -- links - , whenH app.dat.isowner $ \_ -> - div [ class_ "edit_links di" ] - [ button [ type_ ButtonButton, onClick \_ -> Just (BEdit true), class_ "edit light-silver hover-blue" ] [ text "edit  " ] - , div [ class_ "delete_link di" ] - [ button [ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk true), class_ ("delete light-silver hover-blue" <> guard s.deleteAsk " dn") ] [ text "delete" ] - , span ([ class_ ("confirm red" <> guard (not s.deleteAsk) " dn") ] ) - [ button [ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk false)] [ text "cancel / " ] - , button [ type_ ButtonButton, onClick \_ -> Just BDestroy, class_ "red" ] [ text "destroy" ] - ] - ] - ] - , whenH app.dat.isowner $ \_ -> - div [ class_ "read di" ] $ - guard bm.toread - [ text "  " - , button [ onClick \_ -> Just BMarkRead, class_ "mark_read" ] [ text "mark as read"] - ] - ] - - - display_edit _ = - div [ class_ "edit_bookmark_form pa2 pt0 bg-white" ] $ - [ form [ onSubmit (Just <<< BEditSubmit) ] - [ div_ [ text "url" ] - , input [ type_ InputUrl , class_ "url w-100 mb2 pt1 f7 edit_form_input" , required true , name "url" - , value (edit_bm.url) , onValueChange (editField Eurl) ] - , div_ [ text "title" ] - , 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" ] - ] - , div_ [ text "description" ] - , textarea [ class_ "description w-100 mb1 pt1 f7 edit_form_input" , name "description", rows 5 - , value (edit_bm.description) , onValueChange (editField Edescription) ] - , div [ id_ "tags_input_box"] - [ div_ [ text "tags" ] - , input [ id_ (tagid edit_bm), type_ InputText , class_ "tags w-100 mb1 pt1 f7 edit_form_input" , name "tags" - , autocomplete false, attr "autocapitalize" "off" - , value (edit_bm.tags) , onValueChange (editField Etags) ] - ] - , div [ class_ "edit_form_checkboxes mv3"] - [ input [ type_ InputCheckbox , class_ "private pointer" , id_ "edit_private", name "private" - , checked (edit_bm.private) , onChecked (editField Eprivate) ] - , text " " - , label [ for "edit_private" , class_ "mr2" ] [ text "private" ] - , text " " - , input [ type_ InputCheckbox , class_ "toread pointer" , id_ "edit_toread", name "toread" - , checked (edit_bm.toread) , onChecked (editField Etoread) ] - , text " " - , label [ for "edit_toread" ] [ text "to-read" ] - ] - , input [ type_ InputSubmit , class_ "mr1 pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "save" ] - , text " " - , input [ type_ InputReset , class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "cancel" - , onClick \_ -> Just (BEdit false) ] - ] - ] - - - editField :: forall a. (a -> EditField) -> a -> Maybe BAction - editField f = Just <<< BEditField <<< f - linkToFilterSingle slug = fromNullableStr app.userR <> "/b:" <> slug - linkToFilterTag tag = fromNullableStr app.userR <> "/t:" <> tag - shdate = toLocaleDateString bm.time - shdatetime = S.take 16 bm.time `append` "Z" - - tagid bm = show bm.bid <> "_tags" - - handleAction :: BAction -> H.HalogenM BState BAction ChildSlots BMessage Aff Unit - - -- | Star - handleAction (BStar e) = do - bm <- use _bm - H.liftAff (toggleStar bm.bid (if e then Star else UnStar)) - _bm %= _ { selected = e } - _edit_bm %= _ { selected = e } - - -- | Delete - handleAction (BDeleteAsk e) = do - H.modify_ (_ { deleteAsk = e }) - - -- | Destroy - handleAction (BDestroy) = do - bm <- use _bm - void $ H.liftAff (destroy bm.bid) - H.raise BNotifyRemove - - -- | Mark Read - handleAction (BMarkRead) = do - bm <- use _bm - void (H.liftAff (markRead bm.bid)) - _bm %= _ { toread = false } - - -- | Start/Stop Editing - handleAction (BEdit e) = do - bm <- use _bm - _edit_bm .= bm - _edit .= e - H.liftEffect $ - when e - (setFocus (tagid bm)) - - -- | Update Form Field - handleAction (BEditField f) = do - _edit_bm %= case f of - Eurl e -> _ { url = e } - Etitle e -> _ { title = e } - Edescription e -> _ { description = e } - Etags e -> _ { tags = e } - 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) - edit_bm <- use _edit_bm - let edit_bm' = edit_bm { tags = S.replaceAll (Pattern ",") (Replacement " ") edit_bm.tags } - void $ H.liftAff (editBookmark edit_bm') - _bm .= edit_bm' - _edit .= false +module Component.BMark where + +import Prelude hiding (div) + +import App (StarAction(..), destroy, editBookmark, markRead, toggleStar, lookupTitle) +import Component.Markdown as Markdown +import Data.Const (Const) +import Data.Lens (Lens', lens, use, (%=), (.=)) +import Data.Maybe (Maybe(..), fromMaybe, isJust) +import Data.Monoid (guard) +import Data.Nullable (toMaybe) +import Data.String (null, split, take, replaceAll) as S +import Data.String.Pattern (Pattern(..), Replacement(..)) +import Data.Symbol (SProxy(..)) +import Effect.Aff (Aff) +import Globals (app', setFocus, toLocaleDateString) +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, 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) + +-- | UI Events +data BAction + = BStar Boolean + | BDeleteAsk Boolean + | BLookupTitle + | BDestroy + | BEdit Boolean + | BEditField EditField + | BEditSubmit Event + | BMarkRead + +-- | FormField Edits +data EditField + = Eurl String + | Etitle String + | Edescription String + | Etags String + | Eprivate Boolean + | Etoread Boolean + +-- | Messages to parent +data BMessage + = BNotifyRemove + +type BSlot = H.Slot (Const Void) BMessage + +type BState = + { bm :: Bookmark + , edit_bm :: Bookmark + , deleteAsk:: Boolean + , edit :: Boolean + , loading :: Boolean + } + +_bm :: Lens' BState Bookmark +_bm = lens _.bm (_ { bm = _ }) + +_edit_bm :: Lens' BState Bookmark +_edit_bm = lens _.edit_bm (_ { edit_bm = _ }) + +_edit :: Lens' BState Boolean +_edit = lens _.edit (_ { edit = _ }) + +_markdown = SProxy :: SProxy "markdown" + +type ChildSlots = + ( markdown :: Markdown.Slot Unit + ) + +bmark :: forall q i. Bookmark -> H.Component HTML q i BMessage Aff +bmark b' = + H.mkComponent + { initialState: const (mkState b') + , render + , eval: H.mkEval $ H.defaultEval { handleAction = handleAction } + } + where + app = app' unit + + mkState b = + { bm: b + , edit_bm: b + , deleteAsk: false + , edit: false + , loading: false + } + + render :: BState -> H.ComponentHTML BAction ChildSlots Aff + render s@{ bm, edit_bm } = + div [ id_ (show bm.bid) , class_ ("bookmark w-100 mw7 pa1 mb3" <> guard bm.private " private")] $ + [ whenH app.dat.isowner + star + , ifElseH s.edit + display_edit + display + ] + + where + + star _ = + div [ class_ ("star fl pointer" <> guard bm.selected " selected") ] + [ button [ class_ "moon-gray", onClick \_ -> Just (BStar (not bm.selected)) ] [ text "✭" ] ] + + display _ = + div [ class_ "display" ] $ + [ a [ href bm.url, target "_blank", class_ ("link f5 lh-title" <> guard bm.toread " unread")] + [ text $ if S.null bm.title then "[no title]" else bm.title ] + , br_ + , a [ href bm.url , class_ "link f7 gray hover-blue" ] [ text bm.url ] + , a [ href (fromMaybe ("http://archive.is/" <> bm.url) (toMaybe bm.archiveUrl)) + , class_ ("link f7 gray hover-blue ml2" <> (guard (isJust (toMaybe bm.archiveUrl)) " green")) + , target "_blank", title "archive link"] + [ if isJust (toMaybe bm.archiveUrl) then text "☑" else text "☐" ] + , br_ + , div [ class_ "description mt1 mid-gray" ] [ HH.slot _markdown unit Markdown.component bm.description absurd ] + , div [ class_ "tags" ] $ + whenA (not (S.null bm.tags)) $ \_ -> + map (\tag -> a [ class_ ("link tag mr1" <> guard (S.take 1 tag == ".") " private") + , href (linkToFilterTag tag) ] + [ text tag ]) + (S.split (Pattern " ") bm.tags) + + , a [ class_ "link f7 dib gray w4", href (linkToFilterSingle bm.slug), title shdatetime ] + [ text shdate ] + + -- links + , whenH app.dat.isowner $ \_ -> + div [ class_ "edit_links di" ] + [ button [ type_ ButtonButton, onClick \_ -> Just (BEdit true), class_ "edit light-silver hover-blue" ] [ text "edit  " ] + , div [ class_ "delete_link di" ] + [ button [ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk true), class_ ("delete light-silver hover-blue" <> guard s.deleteAsk " dn") ] [ text "delete" ] + , span ([ class_ ("confirm red" <> guard (not s.deleteAsk) " dn") ] ) + [ button [ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk false)] [ text "cancel / " ] + , button [ type_ ButtonButton, onClick \_ -> Just BDestroy, class_ "red" ] [ text "destroy" ] + ] + ] + ] + , whenH app.dat.isowner $ \_ -> + div [ class_ "read di" ] $ + guard bm.toread + [ text "  " + , button [ onClick \_ -> Just BMarkRead, class_ "mark_read" ] [ text "mark as read"] + ] + ] + + + display_edit _ = + div [ class_ "edit_bookmark_form pa2 pt0 bg-white" ] $ + [ form [ onSubmit (Just <<< BEditSubmit) ] + [ div_ [ text "url" ] + , input [ type_ InputUrl , class_ "url w-100 mb2 pt1 f7 edit_form_input" , required true , name "url" + , value (edit_bm.url) , onValueChange (editField Eurl) ] + , div_ [ text "title" ] + , 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" ] + ] + , div_ [ text "description" ] + , textarea [ class_ "description w-100 mb1 pt1 f7 edit_form_input" , name "description", rows 5 + , value (edit_bm.description) , onValueChange (editField Edescription) ] + , div [ id_ "tags_input_box"] + [ div_ [ text "tags" ] + , input [ id_ (tagid edit_bm), type_ InputText , class_ "tags w-100 mb1 pt1 f7 edit_form_input" , name "tags" + , autocomplete false, attr "autocapitalize" "off" + , value (edit_bm.tags) , onValueChange (editField Etags) ] + ] + , div [ class_ "edit_form_checkboxes mv3"] + [ input [ type_ InputCheckbox , class_ "private pointer" , id_ "edit_private", name "private" + , checked (edit_bm.private) , onChecked (editField Eprivate) ] + , text " " + , label [ for "edit_private" , class_ "mr2" ] [ text "private" ] + , text " " + , input [ type_ InputCheckbox , class_ "toread pointer" , id_ "edit_toread", name "toread" + , checked (edit_bm.toread) , onChecked (editField Etoread) ] + , text " " + , label [ for "edit_toread" ] [ text "to-read" ] + ] + , input [ type_ InputSubmit , class_ "mr1 pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "save" ] + , text " " + , input [ type_ InputReset , class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "cancel" + , onClick \_ -> Just (BEdit false) ] + ] + ] + + + editField :: forall a. (a -> EditField) -> a -> Maybe BAction + editField f = Just <<< BEditField <<< f + linkToFilterSingle slug = fromNullableStr app.userR <> "/b:" <> slug + linkToFilterTag tag = fromNullableStr app.userR <> "/t:" <> tag + shdate = toLocaleDateString bm.time + shdatetime = S.take 16 bm.time `append` "Z" + + tagid bm = show bm.bid <> "_tags" + + handleAction :: BAction -> H.HalogenM BState BAction ChildSlots BMessage Aff Unit + + -- | Star + handleAction (BStar e) = do + bm <- use _bm + H.liftAff (toggleStar bm.bid (if e then Star else UnStar)) + _bm %= _ { selected = e } + _edit_bm %= _ { selected = e } + + -- | Delete + handleAction (BDeleteAsk e) = do + H.modify_ (_ { deleteAsk = e }) + + -- | Destroy + handleAction (BDestroy) = do + bm <- use _bm + void $ H.liftAff (destroy bm.bid) + H.raise BNotifyRemove + + -- | Mark Read + handleAction (BMarkRead) = do + bm <- use _bm + void (H.liftAff (markRead bm.bid)) + _bm %= _ { toread = false } + + -- | Start/Stop Editing + handleAction (BEdit e) = do + bm <- use _bm + _edit_bm .= bm + _edit .= e + H.liftEffect $ + when e + (setFocus (tagid bm)) + + -- | Update Form Field + handleAction (BEditField f) = do + _edit_bm %= case f of + Eurl e -> _ { url = e } + Etitle e -> _ { title = e } + Edescription e -> _ { description = e } + Etags e -> _ { tags = e } + 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) + edit_bm <- use _edit_bm + let edit_bm' = edit_bm { tags = S.replaceAll (Pattern ",") (Replacement " ") edit_bm.tags } + void $ H.liftAff (editBookmark edit_bm') + _bm .= edit_bm' + _edit .= false diff --git a/purs/src/Globals.js b/purs/src/Globals.js index bcb53a9..6121783 100644 --- a/purs/src/Globals.js +++ b/purs/src/Globals.js @@ -1,68 +1,68 @@ -"use strict"; - -var moment = require("moment"); - -exports._app = function() { - return app; -} - -exports._closest = function(just, nothing, selector, el) { - var node = el.closest(selector); - if(node) { - return just(node); - } else { - return nothing; - } -} - -exports._innerHtml = function(el) { - return el.innerHTML; -} - -exports._setInnerHtml = function(content, el) { - el.innerHTML = content; - return el; -} - -exports._createFormData = function(formElement) { - return new FormData(formElement); -} - -exports._createFormString = function(formElement) { - return new URLSearchParams(new FormData(formElement)).toString() -} - -exports._createFormArray = function(formElement) { - return Array.from(new FormData(formElement)); -} - -exports._moment8601 = function(tuple, s) { - var m = moment(s, moment.ISO_8601); - var s1 = m.fromNow(); - var s2 = m.format('MMMM D YYYY, h:mm a') + " (" + m.format() + ") "; - return tuple(s1)(s2); -} - -exports._mmoment8601 = function(just, nothing, tuple, s) { - try { - var m = moment(s, moment.ISO_8601); - var s1 = m.fromNow(); - var s2 = m.format('MMMM D YYYY, h:mm a') + " (" + m.format() + ") "; - return just(tuple(s1)(s2)); - } catch (error) { - return nothing - } -} - -exports._closeWindow = function (window) { - window.close(); -}; - -exports._setFocus = function(elemId) { - document.getElementById(elemId).focus(); -}; - - -exports._toLocaleDateString = function(dateString) { - return new Date(dateString).toLocaleDateString(undefined, {dateStyle: 'medium'}) -} +"use strict"; + +var moment = require("moment"); + +exports._app = function() { + return app; +} + +exports._closest = function(just, nothing, selector, el) { + var node = el.closest(selector); + if(node) { + return just(node); + } else { + return nothing; + } +} + +exports._innerHtml = function(el) { + return el.innerHTML; +} + +exports._setInnerHtml = function(content, el) { + el.innerHTML = content; + return el; +} + +exports._createFormData = function(formElement) { + return new FormData(formElement); +} + +exports._createFormString = function(formElement) { + return new URLSearchParams(new FormData(formElement)).toString() +} + +exports._createFormArray = function(formElement) { + return Array.from(new FormData(formElement)); +} + +exports._moment8601 = function(tuple, s) { + var m = moment(s, moment.ISO_8601); + var s1 = m.fromNow(); + var s2 = m.format('MMMM D YYYY, h:mm a') + " (" + m.format() + ") "; + return tuple(s1)(s2); +} + +exports._mmoment8601 = function(just, nothing, tuple, s) { + try { + var m = moment(s, moment.ISO_8601); + var s1 = m.fromNow(); + var s2 = m.format('MMMM D YYYY, h:mm a') + " (" + m.format() + ") "; + return just(tuple(s1)(s2)); + } catch (error) { + return nothing + } +} + +exports._closeWindow = function (window) { + window.close(); +}; + +exports._setFocus = function(elemId) { + document.getElementById(elemId).focus(); +}; + + +exports._toLocaleDateString = function(dateString) { + return new Date(dateString).toLocaleDateString(undefined, {dateStyle: 'medium'}) +} diff --git a/purs/src/Globals.purs b/purs/src/Globals.purs index 03bc27f..cce13b2 100644 --- a/purs/src/Globals.purs +++ b/purs/src/Globals.purs @@ -1,97 +1,97 @@ -module Globals where - -import Data.Maybe (Maybe(..)) -import Data.Newtype (class Newtype) -import Data.Nullable (Nullable) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Data.Function.Uncurried (Fn0, Fn1, Fn4, runFn0, runFn1, runFn4) -import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn4, runEffectFn1, runEffectFn2, runEffectFn4) -import Model (Bookmark) -import Prelude (Unit) -import Web.DOM (Node) -import Web.HTML (HTMLElement, HTMLFormElement, Window) -import Web.XHR.FormData (FormData) - -type App = - { csrfHeaderName :: String - , csrfCookieName :: String - , csrfParamName :: String - , csrfToken :: String - , homeR :: String - , authRlogoutR :: String - , userR :: Nullable String - , noteR :: Nullable String - , dat :: AppData - } - -type AppData = - { bmarks :: Array Bookmark - , bmark :: Bookmark - , isowner :: Boolean - } - -foreign import _app :: Fn0 App - -app' :: Unit -> App -app' _ = runFn0 _app - -foreign import _closest :: forall a. EffectFn4 (a -> Maybe a) (Maybe a) String Node (Maybe Node) - -closest :: String -> Node -> Effect (Maybe Node) -closest selector node = runEffectFn4 _closest Just Nothing selector node - -foreign import _moment8601 :: EffectFn2 (String -> String -> Tuple String String) String (Tuple String String) - -moment8601 :: String -> Effect (Tuple String String) -moment8601 s = runEffectFn2 _moment8601 Tuple s - -foreign import _mmoment8601 :: forall a. Fn4 (a -> Maybe a) (Maybe a) (String -> String -> Tuple String String) String (Maybe (Tuple String String)) - -mmoment8601 :: String -> Maybe (Tuple String String) -mmoment8601 s = runFn4 _mmoment8601 Just Nothing Tuple s - -foreign import _innerHtml :: EffectFn1 HTMLElement String - -innerHtml :: HTMLElement -> Effect String -innerHtml n = runEffectFn1 _innerHtml n - -foreign import _setInnerHtml :: EffectFn2 String HTMLElement HTMLElement - -setInnerHtml :: String -> HTMLElement -> Effect HTMLElement -setInnerHtml c n = runEffectFn2 _setInnerHtml c n - -foreign import _createFormData :: Fn1 HTMLFormElement FormData - -createFormData :: HTMLFormElement -> FormData -createFormData f = runFn1 _createFormData f - -foreign import _createFormString :: Fn1 HTMLFormElement String - -createFormString :: HTMLFormElement -> String -createFormString f = runFn1 _createFormString f - - -foreign import _createFormArray :: Fn1 HTMLFormElement (Array (Array String)) - -createFormArray :: HTMLFormElement -> (Array (Array String)) -createFormArray f = runFn1 _createFormArray f - -foreign import _closeWindow :: EffectFn1 Window Unit - -closeWindow :: Window -> Effect Unit -closeWindow win = runEffectFn1 _closeWindow win - -newtype RawHTML = RawHTML String - -derive instance newtypeRawHTML :: Newtype RawHTML _ - -foreign import _setFocus :: EffectFn1 String Unit - -setFocus :: String -> Effect Unit -setFocus s = runEffectFn1 _setFocus s - -foreign import _toLocaleDateString :: Fn1 String String - -toLocaleDateString :: String -> String -toLocaleDateString s = runFn1 _toLocaleDateString s +module Globals where + +import Data.Maybe (Maybe(..)) +import Data.Newtype (class Newtype) +import Data.Nullable (Nullable) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Data.Function.Uncurried (Fn0, Fn1, Fn4, runFn0, runFn1, runFn4) +import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn4, runEffectFn1, runEffectFn2, runEffectFn4) +import Model (Bookmark) +import Prelude (Unit) +import Web.DOM (Node) +import Web.HTML (HTMLElement, HTMLFormElement, Window) +import Web.XHR.FormData (FormData) + +type App = + { csrfHeaderName :: String + , csrfCookieName :: String + , csrfParamName :: String + , csrfToken :: String + , homeR :: String + , authRlogoutR :: String + , userR :: Nullable String + , noteR :: Nullable String + , dat :: AppData + } + +type AppData = + { bmarks :: Array Bookmark + , bmark :: Bookmark + , isowner :: Boolean + } + +foreign import _app :: Fn0 App + +app' :: Unit -> App +app' _ = runFn0 _app + +foreign import _closest :: forall a. EffectFn4 (a -> Maybe a) (Maybe a) String Node (Maybe Node) + +closest :: String -> Node -> Effect (Maybe Node) +closest selector node = runEffectFn4 _closest Just Nothing selector node + +foreign import _moment8601 :: EffectFn2 (String -> String -> Tuple String String) String (Tuple String String) + +moment8601 :: String -> Effect (Tuple String String) +moment8601 s = runEffectFn2 _moment8601 Tuple s + +foreign import _mmoment8601 :: forall a. Fn4 (a -> Maybe a) (Maybe a) (String -> String -> Tuple String String) String (Maybe (Tuple String String)) + +mmoment8601 :: String -> Maybe (Tuple String String) +mmoment8601 s = runFn4 _mmoment8601 Just Nothing Tuple s + +foreign import _innerHtml :: EffectFn1 HTMLElement String + +innerHtml :: HTMLElement -> Effect String +innerHtml n = runEffectFn1 _innerHtml n + +foreign import _setInnerHtml :: EffectFn2 String HTMLElement HTMLElement + +setInnerHtml :: String -> HTMLElement -> Effect HTMLElement +setInnerHtml c n = runEffectFn2 _setInnerHtml c n + +foreign import _createFormData :: Fn1 HTMLFormElement FormData + +createFormData :: HTMLFormElement -> FormData +createFormData f = runFn1 _createFormData f + +foreign import _createFormString :: Fn1 HTMLFormElement String + +createFormString :: HTMLFormElement -> String +createFormString f = runFn1 _createFormString f + + +foreign import _createFormArray :: Fn1 HTMLFormElement (Array (Array String)) + +createFormArray :: HTMLFormElement -> (Array (Array String)) +createFormArray f = runFn1 _createFormArray f + +foreign import _closeWindow :: EffectFn1 Window Unit + +closeWindow :: Window -> Effect Unit +closeWindow win = runEffectFn1 _closeWindow win + +newtype RawHTML = RawHTML String + +derive instance newtypeRawHTML :: Newtype RawHTML _ + +foreign import _setFocus :: EffectFn1 String Unit + +setFocus :: String -> Effect Unit +setFocus s = runEffectFn1 _setFocus s + +foreign import _toLocaleDateString :: Fn1 String String + +toLocaleDateString :: String -> String +toLocaleDateString s = runFn1 _toLocaleDateString s diff --git a/purs/src/Main.purs b/purs/src/Main.purs index df14626..7ec87e9 100644 --- a/purs/src/Main.purs +++ b/purs/src/Main.purs @@ -1,75 +1,75 @@ -module Main where - -import Prelude - -import App (logout) -import Component.AccountSettings (usetting) -import Component.Add (addbmark) -import Component.BList (blist) -import Component.NList (nlist) -import Component.NNote (nnote) -import Component.TagCloud (tagcloudcomponent) -import Data.Foldable (traverse_) -import Effect (Effect) -import Effect.Aff (Aff, launchAff) -import Effect.Class (liftEffect) -import Halogen.Aff as HA -import Halogen.VDom.Driver (runUI) -import Model (AccountSettings, Bookmark, Note, TagCloudMode, tagCloudModeToF) -import Web.DOM.Element (setAttribute) -import Web.DOM.ParentNode (QuerySelector(..)) -import Web.Event.Event (Event, preventDefault) -import Web.HTML.HTMLElement (toElement) - -foreign import _mainImpl :: Effect Unit - -main :: Effect Unit -main = _mainImpl - -logoutE :: Event -> Effect Unit -logoutE e = void <<< launchAff <<< logout =<< preventDefault e - -renderBookmarks :: String -> Array Bookmark -> Effect Unit -renderBookmarks renderElSelector bmarks = do - HA.runHalogenAff do - HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do - void $ runUI (blist bmarks) unit el - viewRendered - -renderTagCloud :: String -> TagCloudMode -> Effect Unit -renderTagCloud renderElSelector tagCloudMode = do - HA.runHalogenAff do - HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do - void $ runUI (tagcloudcomponent (tagCloudModeToF tagCloudMode)) unit el - -renderAddForm :: String -> Bookmark -> Effect Unit -renderAddForm renderElSelector bmark = do - HA.runHalogenAff do - HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do - void $ runUI (addbmark bmark) unit el - viewRendered - -renderNotes :: String -> Array Note -> Effect Unit -renderNotes renderElSelector notes = do - HA.runHalogenAff do - HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do - void $ runUI (nlist notes) unit el - viewRendered - -renderNote :: String -> Note -> Effect Unit -renderNote renderElSelector note = do - HA.runHalogenAff do - HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do - void $ runUI (nnote note) unit el - viewRendered - -renderAccountSettings :: String -> AccountSettings -> Effect Unit -renderAccountSettings renderElSelector accountSettings = do - HA.runHalogenAff do - HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do - void $ runUI (usetting accountSettings) unit el - viewRendered - -viewRendered :: Aff Unit -viewRendered = HA.selectElement (QuerySelector "#content") >>= traverse_ \el -> - liftEffect $ setAttribute "view-rendered" "" (toElement el) +module Main where + +import Prelude + +import App (logout) +import Component.AccountSettings (usetting) +import Component.Add (addbmark) +import Component.BList (blist) +import Component.NList (nlist) +import Component.NNote (nnote) +import Component.TagCloud (tagcloudcomponent) +import Data.Foldable (traverse_) +import Effect (Effect) +import Effect.Aff (Aff, launchAff) +import Effect.Class (liftEffect) +import Halogen.Aff as HA +import Halogen.VDom.Driver (runUI) +import Model (AccountSettings, Bookmark, Note, TagCloudMode, tagCloudModeToF) +import Web.DOM.Element (setAttribute) +import Web.DOM.ParentNode (QuerySelector(..)) +import Web.Event.Event (Event, preventDefault) +import Web.HTML.HTMLElement (toElement) + +foreign import _mainImpl :: Effect Unit + +main :: Effect Unit +main = _mainImpl + +logoutE :: Event -> Effect Unit +logoutE e = void <<< launchAff <<< logout =<< preventDefault e + +renderBookmarks :: String -> Array Bookmark -> Effect Unit +renderBookmarks renderElSelector bmarks = do + HA.runHalogenAff do + HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do + void $ runUI (blist bmarks) unit el + viewRendered + +renderTagCloud :: String -> TagCloudMode -> Effect Unit +renderTagCloud renderElSelector tagCloudMode = do + HA.runHalogenAff do + HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do + void $ runUI (tagcloudcomponent (tagCloudModeToF tagCloudMode)) unit el + +renderAddForm :: String -> Bookmark -> Effect Unit +renderAddForm renderElSelector bmark = do + HA.runHalogenAff do + HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do + void $ runUI (addbmark bmark) unit el + viewRendered + +renderNotes :: String -> Array Note -> Effect Unit +renderNotes renderElSelector notes = do + HA.runHalogenAff do + HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do + void $ runUI (nlist notes) unit el + viewRendered + +renderNote :: String -> Note -> Effect Unit +renderNote renderElSelector note = do + HA.runHalogenAff do + HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do + void $ runUI (nnote note) unit el + viewRendered + +renderAccountSettings :: String -> AccountSettings -> Effect Unit +renderAccountSettings renderElSelector accountSettings = do + HA.runHalogenAff do + HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do + void $ runUI (usetting accountSettings) unit el + viewRendered + +viewRendered :: Aff Unit +viewRendered = HA.selectElement (QuerySelector "#content") >>= traverse_ \el -> + liftEffect $ setAttribute "view-rendered" "" (toElement el) diff --git a/purs/src/Util.purs b/purs/src/Util.purs index b4fdad0..46fc506 100644 --- a/purs/src/Util.purs +++ b/purs/src/Util.purs @@ -1,148 +1,148 @@ -module Util where - -import Prelude - -import Control.Monad.Maybe.Trans (MaybeT(..)) -import Data.Array (filter, find, mapMaybe) -import Data.Foldable (for_) -import Data.Maybe (Maybe(..), fromJust, fromMaybe, maybe) -import Data.Nullable (Nullable, toMaybe) -import Data.String (Pattern(..), Replacement(..), drop, replaceAll, split, take) -import Data.Tuple (Tuple(..), fst, snd) -import Effect (Effect) -import Global.Unsafe (unsafeDecodeURIComponent) -import Halogen (ClassName(..)) -import Halogen.HTML as HH -import Halogen.HTML.Properties as HP -import Partial.Unsafe (unsafePartial) -import Web.DOM (Element, Node) -import Web.DOM.Document (toNonElementParentNode) -import Web.DOM.Element (fromNode, toParentNode) -import Web.DOM.NodeList (toArray) -import Web.DOM.NonElementParentNode (getElementById) -import Web.DOM.ParentNode (QuerySelector(..), querySelector, querySelectorAll) -import Web.HTML (HTMLDocument, Location, window) -import Web.HTML.HTMLDocument (body) as HD -import Web.HTML.HTMLDocument (toDocument) -import Web.HTML.HTMLElement (HTMLElement) -import Web.HTML.HTMLElement (fromElement) as HE -import Web.HTML.Location (search) -import Web.HTML.Window (document, location) - --- Halogen - -class_ :: forall r i. String -> HP.IProp ( "class" :: String | r) i -class_ = HP.class_ <<< HH.ClassName - -attr :: forall r i. String -> String -> HP.IProp r i -attr a = HP.attr (HH.AttrName a) - --- Util - -_queryBoth :: forall a. Tuple String Element -> Tuple String Element -> (Element -> Element -> Effect a) -> Effect Unit -_queryBoth (Tuple qa ea) (Tuple qb eb) f = do - ma <- _querySelector qa ea - mb <- _querySelector qb eb - for_ ma \a -> - for_ mb \b -> - f a b - -_queryBoth' :: forall a. Tuple String Element -> Tuple String Element -> (Element -> Array Node -> Effect a) -> Effect Unit -_queryBoth' (Tuple qa ea) (Tuple qb eb) f = do - ma <- _querySelector qa ea - bs <- _querySelectorAll qb eb - for_ ma \a -> - f a bs - -_queryBoth'' :: forall a. Tuple String Element -> Tuple String Element -> (Array Node -> Array Node -> Effect a) -> Effect a -_queryBoth'' (Tuple qa ea) (Tuple qb eb) f = do - as <- _querySelectorAll qa ea - bs <- _querySelectorAll qb eb - f as bs - -_querySelector :: String -> Element -> Effect (Maybe Element) -_querySelector s n = querySelector (QuerySelector s) (toParentNode n) - -_querySelectorAll :: String -> Element -> Effect (Array Node) -_querySelectorAll s n = toArray =<< querySelectorAll (QuerySelector s) (toParentNode n) - -_fromNode :: Node -> Element -_fromNode e = unsafePartial $ fromJust (fromNode e) - -_fromElement :: Element -> HTMLElement -_fromElement e = unsafePartial $ fromJust (HE.fromElement e) - -_getElementById :: String -> HTMLDocument -> Effect (Maybe Element) -_getElementById s = getElementById s <<< toNonElementParentNode <<< toDocument - -_doc :: Effect HTMLDocument -_doc = document =<< window - -_loc :: Effect Location -_loc = location =<< window - -type QueryStringArray = Array (Tuple String (Maybe String)) - -_curQuerystring :: Effect QueryStringArray -_curQuerystring = do - loc <- _loc - srh <- search loc - pure $ _parseQueryString srh - -_parseQueryString :: String -> QueryStringArray -_parseQueryString srh = do - let qs = let srh' = take 1 srh in if (srh' == "#" || srh' == "?") then drop 1 srh else srh - mapMaybe go $ (filter (_ /= "") <<< split (Pattern "&")) qs - where - decode = unsafeDecodeURIComponent <<< replaceAll (Pattern "+") (Replacement " ") - go kv = - case split (Pattern "=") kv of - [k] -> Just (Tuple (decode k) Nothing) - [k, v] -> Just (Tuple (decode k) (Just (decode v))) - _ -> Nothing - -_lookupQueryStringValue :: QueryStringArray -> String -> Maybe String -_lookupQueryStringValue qs k = do - join $ map snd $ find ((_ == k) <<< fst) qs - -_body :: Effect HTMLElement -_body = unsafePartial $ pure <<< fromJust =<< HD.body =<< _doc - -_mt :: forall a. Effect (Maybe a) -> MaybeT Effect a -_mt = MaybeT - -_mt_pure :: forall a. Maybe a -> MaybeT Effect a -_mt_pure = MaybeT <<< pure - -dummyAttr :: forall r i. HP.IProp r i -dummyAttr = HP.attr (HH.AttrName "data-dummy") "" - -whenP :: forall r i. Boolean -> HP.IProp r i -> HP.IProp r i -whenP b p = if b then p else dummyAttr - -maybeP :: forall a r i. Maybe a -> (a -> HP.IProp r i) -> HP.IProp r i -maybeP m p = maybe dummyAttr p m - -whenC :: Boolean -> ClassName -> ClassName -whenC b c = if b then c else ClassName "" - -whenH :: forall p i. Boolean -> (Unit -> HH.HTML p i) -> HH.HTML p i -whenH b k = if b then k unit else HH.text "" - -whenA :: forall t. Boolean -> (Unit -> Array t) -> Array t -whenA b k = if b then k unit else [] - -ifElseH :: forall p i. Boolean -> (Unit -> HH.HTML p i) -> (Unit -> HH.HTML p i) -> HH.HTML p i -ifElseH b f k = if b then f unit else k unit - -ifElseA :: forall t. Boolean -> (Unit -> Array t) -> (Unit -> Array t) -> Array t -ifElseA b f k = if b then f unit else k unit - -maybeH :: forall a p i. Maybe a -> (a -> HH.HTML p i) -> HH.HTML p i -maybeH m k = maybe (HH.text "") k m - -fromNullableStr :: Nullable String -> String -fromNullableStr = fromMaybe "" <<< toMaybe - -monthNames :: Array String -monthNames = ["january", "february", "march", "april", "may", "june", "july", "august", "september", "october", "november", "december"] +module Util where + +import Prelude + +import Control.Monad.Maybe.Trans (MaybeT(..)) +import Data.Array (filter, find, mapMaybe) +import Data.Foldable (for_) +import Data.Maybe (Maybe(..), fromJust, fromMaybe, maybe) +import Data.Nullable (Nullable, toMaybe) +import Data.String (Pattern(..), Replacement(..), drop, replaceAll, split, take) +import Data.Tuple (Tuple(..), fst, snd) +import Effect (Effect) +import Global.Unsafe (unsafeDecodeURIComponent) +import Halogen (ClassName(..)) +import Halogen.HTML as HH +import Halogen.HTML.Properties as HP +import Partial.Unsafe (unsafePartial) +import Web.DOM (Element, Node) +import Web.DOM.Document (toNonElementParentNode) +import Web.DOM.Element (fromNode, toParentNode) +import Web.DOM.NodeList (toArray) +import Web.DOM.NonElementParentNode (getElementById) +import Web.DOM.ParentNode (QuerySelector(..), querySelector, querySelectorAll) +import Web.HTML (HTMLDocument, Location, window) +import Web.HTML.HTMLDocument (body) as HD +import Web.HTML.HTMLDocument (toDocument) +import Web.HTML.HTMLElement (HTMLElement) +import Web.HTML.HTMLElement (fromElement) as HE +import Web.HTML.Location (search) +import Web.HTML.Window (document, location) + +-- Halogen + +class_ :: forall r i. String -> HP.IProp ( "class" :: String | r) i +class_ = HP.class_ <<< HH.ClassName + +attr :: forall r i. String -> String -> HP.IProp r i +attr a = HP.attr (HH.AttrName a) + +-- Util + +_queryBoth :: forall a. Tuple String Element -> Tuple String Element -> (Element -> Element -> Effect a) -> Effect Unit +_queryBoth (Tuple qa ea) (Tuple qb eb) f = do + ma <- _querySelector qa ea + mb <- _querySelector qb eb + for_ ma \a -> + for_ mb \b -> + f a b + +_queryBoth' :: forall a. Tuple String Element -> Tuple String Element -> (Element -> Array Node -> Effect a) -> Effect Unit +_queryBoth' (Tuple qa ea) (Tuple qb eb) f = do + ma <- _querySelector qa ea + bs <- _querySelectorAll qb eb + for_ ma \a -> + f a bs + +_queryBoth'' :: forall a. Tuple String Element -> Tuple String Element -> (Array Node -> Array Node -> Effect a) -> Effect a +_queryBoth'' (Tuple qa ea) (Tuple qb eb) f = do + as <- _querySelectorAll qa ea + bs <- _querySelectorAll qb eb + f as bs + +_querySelector :: String -> Element -> Effect (Maybe Element) +_querySelector s n = querySelector (QuerySelector s) (toParentNode n) + +_querySelectorAll :: String -> Element -> Effect (Array Node) +_querySelectorAll s n = toArray =<< querySelectorAll (QuerySelector s) (toParentNode n) + +_fromNode :: Node -> Element +_fromNode e = unsafePartial $ fromJust (fromNode e) + +_fromElement :: Element -> HTMLElement +_fromElement e = unsafePartial $ fromJust (HE.fromElement e) + +_getElementById :: String -> HTMLDocument -> Effect (Maybe Element) +_getElementById s = getElementById s <<< toNonElementParentNode <<< toDocument + +_doc :: Effect HTMLDocument +_doc = document =<< window + +_loc :: Effect Location +_loc = location =<< window + +type QueryStringArray = Array (Tuple String (Maybe String)) + +_curQuerystring :: Effect QueryStringArray +_curQuerystring = do + loc <- _loc + srh <- search loc + pure $ _parseQueryString srh + +_parseQueryString :: String -> QueryStringArray +_parseQueryString srh = do + let qs = let srh' = take 1 srh in if (srh' == "#" || srh' == "?") then drop 1 srh else srh + mapMaybe go $ (filter (_ /= "") <<< split (Pattern "&")) qs + where + decode = unsafeDecodeURIComponent <<< replaceAll (Pattern "+") (Replacement " ") + go kv = + case split (Pattern "=") kv of + [k] -> Just (Tuple (decode k) Nothing) + [k, v] -> Just (Tuple (decode k) (Just (decode v))) + _ -> Nothing + +_lookupQueryStringValue :: QueryStringArray -> String -> Maybe String +_lookupQueryStringValue qs k = do + join $ map snd $ find ((_ == k) <<< fst) qs + +_body :: Effect HTMLElement +_body = unsafePartial $ pure <<< fromJust =<< HD.body =<< _doc + +_mt :: forall a. Effect (Maybe a) -> MaybeT Effect a +_mt = MaybeT + +_mt_pure :: forall a. Maybe a -> MaybeT Effect a +_mt_pure = MaybeT <<< pure + +dummyAttr :: forall r i. HP.IProp r i +dummyAttr = HP.attr (HH.AttrName "data-dummy") "" + +whenP :: forall r i. Boolean -> HP.IProp r i -> HP.IProp r i +whenP b p = if b then p else dummyAttr + +maybeP :: forall a r i. Maybe a -> (a -> HP.IProp r i) -> HP.IProp r i +maybeP m p = maybe dummyAttr p m + +whenC :: Boolean -> ClassName -> ClassName +whenC b c = if b then c else ClassName "" + +whenH :: forall p i. Boolean -> (Unit -> HH.HTML p i) -> HH.HTML p i +whenH b k = if b then k unit else HH.text "" + +whenA :: forall t. Boolean -> (Unit -> Array t) -> Array t +whenA b k = if b then k unit else [] + +ifElseH :: forall p i. Boolean -> (Unit -> HH.HTML p i) -> (Unit -> HH.HTML p i) -> HH.HTML p i +ifElseH b f k = if b then f unit else k unit + +ifElseA :: forall t. Boolean -> (Unit -> Array t) -> (Unit -> Array t) -> Array t +ifElseA b f k = if b then f unit else k unit + +maybeH :: forall a p i. Maybe a -> (a -> HH.HTML p i) -> HH.HTML p i +maybeH m k = maybe (HH.text "") k m + +fromNullableStr :: Nullable String -> String +fromNullableStr = fromMaybe "" <<< toMaybe + +monthNames :: Array String +monthNames = ["january", "february", "march", "april", "may", "june", "july", "august", "september", "october", "november", "december"] diff --git a/src/Foundation.hs b/src/Foundation.hs index 5394db5..c96c9db 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,252 +1,252 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} - -module Foundation where - -import Import.NoFoundation -import Database.Persist.Sql (ConnectionPool, runSqlPool) -import Text.Hamlet (hamletFile) -import Text.Jasmine (minifym) -import PathPiece() - --- import Yesod.Auth.Dummy - -import Yesod.Default.Util (addStaticContentExternal) -import Yesod.Core.Types -import Yesod.Auth.Message --- import qualified Network.Wai as NW --- import qualified Control.Monad.Metrics as MM -import qualified Data.CaseInsensitive as CI -import qualified Data.Text.Encoding as TE -import qualified Yesod.Core.Unsafe as Unsafe - -data App = App - { appSettings :: AppSettings - , appStatic :: Static -- ^ Settings for static file serving. - , appConnPool :: ConnectionPool -- ^ Database connection pool. - , appHttpManager :: Manager - , appLogger :: Logger - -- , appMetrics :: !MM.Metrics - } deriving (Typeable) - -mkYesodData "App" $(parseRoutesFile "config/routes") - -deriving instance Typeable Route -deriving instance Generic (Route App) - --- YesodPersist - -instance YesodPersist App where - type YesodPersistBackend App = SqlBackend - runDB action = do - master <- getYesod - runSqlPool action (appConnPool master) - -instance YesodPersistRunner App where - getDBRunner = defaultGetDBRunner appConnPool - --- Yesod - -instance Yesod App where - approot = ApprootRequest \app req -> - case appRoot (appSettings app) of - Nothing -> getApprootText guessApproot app req - Just root -> root - - makeSessionBackend _ = Just <$> defaultClientSessionBackend - 10080 -- min (7 days) - "config/client_session_key.aes" - - -- yesodMiddleware = metricsMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware - yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware - - defaultLayout widget = do - req <- getRequest - master <- getYesod - urlrender <- getUrlRender - mmsg <- getMessage - musername <- maybeAuthUsername - muser <- (fmap.fmap) snd maybeAuthPair - mcurrentRoute <- getCurrentRoute - -- void $ mapM (incrementRouteEKG req) mcurrentRoute - let msourceCodeUri = appSourceCodeUri (appSettings master) - pc <- widgetToPageContent do - setTitle "Espial" - addAppScripts - addStylesheet (StaticR css_tachyons_min_css) - addStylesheet (StaticR css_main_css) - $(widgetFile "default-layout") - withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - - addStaticContent ext mime content = do - master <- getYesod - let staticDir = appStaticDir (appSettings master) - addStaticContentExternal - minifym - genFileName - staticDir - (StaticR . flip StaticRoute []) - ext - mime - content - where - genFileName lbs = "autogen-" ++ base64md5 lbs - - shouldLogIO app _source level = - pure $ appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError - makeLogger = return . appLogger - - authRoute _ = Just (AuthR LoginR) - - isAuthorized (AuthR _) _ = pure Authorized - isAuthorized _ _ = pure Authorized - - defaultMessageWidget title body = do - setTitle title - toWidget [hamlet| -
-
-
-

#{title} - ^{body} - |] - - -isAuthenticated :: Handler AuthResult -isAuthenticated = maybeAuthId >>= \case - Just authId -> pure Authorized - _ -> pure $ AuthenticationRequired - -addAppScripts :: (MonadWidget m, HandlerSite m ~ App) => m () -addAppScripts = do - addScript (StaticR js_app_min_js) - - --- popupLayout - -popupLayout :: Widget -> Handler Html -popupLayout widget = do - req <- getRequest - master <- getYesod - mmsg <- getMessage - musername <- maybeAuthUsername - let msourceCodeUri = appSourceCodeUri (appSettings master) - pc <- widgetToPageContent do - addAppScripts - addStylesheet (StaticR css_tachyons_min_css) - addStylesheet (StaticR css_popup_css) - $(widgetFile "popup-layout") - withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - - --- metricsMiddleware :: Handler a -> Handler a --- metricsMiddleware handler = do --- req <- getRequest --- mcurrentRoute <- getCurrentRoute --- void $ mapM (incrementRouteEKG req) mcurrentRoute --- handler - - --- incrementRouteEKG :: YesodRequest -> Route App -> Handler () --- incrementRouteEKG req = MM.increment . (\r -> "route." <> r <> "." <> method) . pack . constrName --- where method = decodeUtf8 $ NW.requestMethod $ reqWaiRequest req - --- YesodAuth - -instance YesodAuth App where - type AuthId App = UserId - -- authHttpManager = getHttpManager - authPlugins _ = [dbAuthPlugin] - authenticate = authenticateCreds - loginDest = const HomeR - logoutDest = const HomeR - onLogin = maybeAuth >>= \case - Nothing -> cpprint ("onLogin: could not find user" :: Text) - Just (Entity _ uname) -> setSession userNameKey (userName uname) - onLogout = - deleteSession userNameKey - redirectToReferer = const True - -instance YesodAuthPersist App - --- instance MM.MonadMetrics Handler where --- getMetrics = pure . appMetrics =<< getYesod - --- session keys - -maybeAuthUsername :: Handler (Maybe Text) -maybeAuthUsername = do - lookupSession userNameKey - -ultDestKey :: Text -ultDestKey = "_ULT" - -userNameKey :: Text -userNameKey = "_UNAME" - --- dbAuthPlugin - -dbAuthPluginName :: Text -dbAuthPluginName = "db" - -dbAuthPlugin :: AuthPlugin App -dbAuthPlugin = AuthPlugin dbAuthPluginName dbDispatch dbLoginHandler - where - dbDispatch "POST" ["login"] = dbPostLoginR >>= sendResponse - dbDispatch _ _ = notFound - dbLoginHandler toParent = do - req <- getRequest - lookupSession ultDestKey >>= \case - Just dest | "logout" `isInfixOf` dest -> deleteSession ultDestKey - _ -> pure () - setTitle "Espial | Log In" - $(widgetFile "login") - -dbLoginR :: AuthRoute -dbLoginR = PluginR dbAuthPluginName ["login"] - -dbPostLoginR :: AuthHandler master TypedContent -dbPostLoginR = do - mresult <- runInputPostResult (dbLoginCreds - <$> ireq textField "username" - <*> ireq textField "password") - case mresult of - FormSuccess creds -> setCredsRedirect creds - _ -> loginErrorMessageI LoginR InvalidUsernamePass - -dbLoginCreds :: Text -> Text -> Creds master -dbLoginCreds username password = - Creds - { credsPlugin = dbAuthPluginName - , credsIdent = username - , credsExtra = [("password", password)] - } - -authenticateCreds :: - (MonadHandler m, HandlerSite m ~ App) - => Creds App - -> m (AuthenticationResult App) -authenticateCreds Creds {..} = do - muser <- - case credsPlugin of - p | p == dbAuthPluginName -> liftHandler $ runDB $ - join <$> mapM (authenticatePassword credsIdent) (lookup "password" credsExtra) - _ -> pure Nothing - case muser of - Nothing -> pure (UserError InvalidUsernamePass) - Just (Entity uid _) -> pure (Authenticated uid) - --- Util - -instance RenderMessage App FormMessage where - renderMessage :: App -> [Lang] -> FormMessage -> Text - renderMessage _ _ = defaultFormMessage - -instance HasHttpManager App where - getHttpManager :: App -> Manager - getHttpManager = appHttpManager - -unsafeHandler :: App -> Handler a -> IO a -unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger - +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +module Foundation where + +import Import.NoFoundation +import Database.Persist.Sql (ConnectionPool, runSqlPool) +import Text.Hamlet (hamletFile) +import Text.Jasmine (minifym) +import PathPiece() + +-- import Yesod.Auth.Dummy + +import Yesod.Default.Util (addStaticContentExternal) +import Yesod.Core.Types +import Yesod.Auth.Message +-- import qualified Network.Wai as NW +-- import qualified Control.Monad.Metrics as MM +import qualified Data.CaseInsensitive as CI +import qualified Data.Text.Encoding as TE +import qualified Yesod.Core.Unsafe as Unsafe + +data App = App + { appSettings :: AppSettings + , appStatic :: Static -- ^ Settings for static file serving. + , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appHttpManager :: Manager + , appLogger :: Logger + -- , appMetrics :: !MM.Metrics + } deriving (Typeable) + +mkYesodData "App" $(parseRoutesFile "config/routes") + +deriving instance Typeable Route +deriving instance Generic (Route App) + +-- YesodPersist + +instance YesodPersist App where + type YesodPersistBackend App = SqlBackend + runDB action = do + master <- getYesod + runSqlPool action (appConnPool master) + +instance YesodPersistRunner App where + getDBRunner = defaultGetDBRunner appConnPool + +-- Yesod + +instance Yesod App where + approot = ApprootRequest \app req -> + case appRoot (appSettings app) of + Nothing -> getApprootText guessApproot app req + Just root -> root + + makeSessionBackend _ = Just <$> defaultClientSessionBackend + 10080 -- min (7 days) + "config/client_session_key.aes" + + -- yesodMiddleware = metricsMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware + yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware + + defaultLayout widget = do + req <- getRequest + master <- getYesod + urlrender <- getUrlRender + mmsg <- getMessage + musername <- maybeAuthUsername + muser <- (fmap.fmap) snd maybeAuthPair + mcurrentRoute <- getCurrentRoute + -- void $ mapM (incrementRouteEKG req) mcurrentRoute + let msourceCodeUri = appSourceCodeUri (appSettings master) + pc <- widgetToPageContent do + setTitle "Espial" + addAppScripts + addStylesheet (StaticR css_tachyons_min_css) + addStylesheet (StaticR css_main_css) + $(widgetFile "default-layout") + withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") + + addStaticContent ext mime content = do + master <- getYesod + let staticDir = appStaticDir (appSettings master) + addStaticContentExternal + minifym + genFileName + staticDir + (StaticR . flip StaticRoute []) + ext + mime + content + where + genFileName lbs = "autogen-" ++ base64md5 lbs + + shouldLogIO app _source level = + pure $ appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError + makeLogger = return . appLogger + + authRoute _ = Just (AuthR LoginR) + + isAuthorized (AuthR _) _ = pure Authorized + isAuthorized _ _ = pure Authorized + + defaultMessageWidget title body = do + setTitle title + toWidget [hamlet| +
+
+
+

#{title} + ^{body} + |] + + +isAuthenticated :: Handler AuthResult +isAuthenticated = maybeAuthId >>= \case + Just authId -> pure Authorized + _ -> pure $ AuthenticationRequired + +addAppScripts :: (MonadWidget m, HandlerSite m ~ App) => m () +addAppScripts = do + addScript (StaticR js_app_min_js) + + +-- popupLayout + +popupLayout :: Widget -> Handler Html +popupLayout widget = do + req <- getRequest + master <- getYesod + mmsg <- getMessage + musername <- maybeAuthUsername + let msourceCodeUri = appSourceCodeUri (appSettings master) + pc <- widgetToPageContent do + addAppScripts + addStylesheet (StaticR css_tachyons_min_css) + addStylesheet (StaticR css_popup_css) + $(widgetFile "popup-layout") + withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") + + +-- metricsMiddleware :: Handler a -> Handler a +-- metricsMiddleware handler = do +-- req <- getRequest +-- mcurrentRoute <- getCurrentRoute +-- void $ mapM (incrementRouteEKG req) mcurrentRoute +-- handler + + +-- incrementRouteEKG :: YesodRequest -> Route App -> Handler () +-- incrementRouteEKG req = MM.increment . (\r -> "route." <> r <> "." <> method) . pack . constrName +-- where method = decodeUtf8 $ NW.requestMethod $ reqWaiRequest req + +-- YesodAuth + +instance YesodAuth App where + type AuthId App = UserId + -- authHttpManager = getHttpManager + authPlugins _ = [dbAuthPlugin] + authenticate = authenticateCreds + loginDest = const HomeR + logoutDest = const HomeR + onLogin = maybeAuth >>= \case + Nothing -> cpprint ("onLogin: could not find user" :: Text) + Just (Entity _ uname) -> setSession userNameKey (userName uname) + onLogout = + deleteSession userNameKey + redirectToReferer = const True + +instance YesodAuthPersist App + +-- instance MM.MonadMetrics Handler where +-- getMetrics = pure . appMetrics =<< getYesod + +-- session keys + +maybeAuthUsername :: Handler (Maybe Text) +maybeAuthUsername = do + lookupSession userNameKey + +ultDestKey :: Text +ultDestKey = "_ULT" + +userNameKey :: Text +userNameKey = "_UNAME" + +-- dbAuthPlugin + +dbAuthPluginName :: Text +dbAuthPluginName = "db" + +dbAuthPlugin :: AuthPlugin App +dbAuthPlugin = AuthPlugin dbAuthPluginName dbDispatch dbLoginHandler + where + dbDispatch "POST" ["login"] = dbPostLoginR >>= sendResponse + dbDispatch _ _ = notFound + dbLoginHandler toParent = do + req <- getRequest + lookupSession ultDestKey >>= \case + Just dest | "logout" `isInfixOf` dest -> deleteSession ultDestKey + _ -> pure () + setTitle "Espial | Log In" + $(widgetFile "login") + +dbLoginR :: AuthRoute +dbLoginR = PluginR dbAuthPluginName ["login"] + +dbPostLoginR :: AuthHandler master TypedContent +dbPostLoginR = do + mresult <- runInputPostResult (dbLoginCreds + <$> ireq textField "username" + <*> ireq textField "password") + case mresult of + FormSuccess creds -> setCredsRedirect creds + _ -> loginErrorMessageI LoginR InvalidUsernamePass + +dbLoginCreds :: Text -> Text -> Creds master +dbLoginCreds username password = + Creds + { credsPlugin = dbAuthPluginName + , credsIdent = username + , credsExtra = [("password", password)] + } + +authenticateCreds :: + (MonadHandler m, HandlerSite m ~ App) + => Creds App + -> m (AuthenticationResult App) +authenticateCreds Creds {..} = do + muser <- + case credsPlugin of + p | p == dbAuthPluginName -> liftHandler $ runDB $ + join <$> mapM (authenticatePassword credsIdent) (lookup "password" credsExtra) + _ -> pure Nothing + case muser of + Nothing -> pure (UserError InvalidUsernamePass) + Just (Entity uid _) -> pure (Authenticated uid) + +-- Util + +instance RenderMessage App FormMessage where + renderMessage :: App -> [Lang] -> FormMessage -> Text + renderMessage _ _ = defaultFormMessage + +instance HasHttpManager App where + getHttpManager :: App -> Manager + getHttpManager = appHttpManager + +unsafeHandler :: App -> Handler a -> IO a +unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger + diff --git a/src/Handler/Add.hs b/src/Handler/Add.hs index 4f57578..db5161a 100644 --- a/src/Handler/Add.hs +++ b/src/Handler/Add.hs @@ -1,84 +1,84 @@ -module Handler.Add where - -import Import -import Handler.Archive -import Data.List (nub) -import qualified Data.Text as T (replace) - --- View - -getAddViewR :: Handler Html -getAddViewR = do - userId <- requireAuthId - - murl <- lookupGetParam "url" - mformdb <- runDB (pure . fmap _toBookmarkForm =<< fetchBookmarkByUrl userId murl) - formurl <- bookmarkFormUrl - - let renderEl = "addForm" :: Text - - popupLayout do - toWidget [whamlet| -
- |] - toWidgetBody [julius| - app.dat.bmark = #{ toJSON (fromMaybe formurl mformdb) }; - |] - toWidget [julius| - PS['Main'].renderAddForm('##{rawJS renderEl}')(app.dat.bmark)(); - |] - -bookmarkFormUrl :: Handler BookmarkForm -bookmarkFormUrl = do - Entity _ user <- requireAuth - url <- lookupGetParam "url" >>= pure . fromMaybe "" - title <- lookupGetParam "title" - description <- lookupGetParam "description" >>= pure . fmap Textarea - tags <- lookupGetParam "tags" - private <- lookupGetParam "private" >>= pure . fmap parseChk <&> (<|> Just (userPrivateDefault user)) - toread <- lookupGetParam "toread" >>= pure . fmap parseChk - pure $ - BookmarkForm - { _url = url - , _title = title - , _description = description - , _tags = tags - , _private = private - , _toread = toread - , _bid = Nothing - , _slug = Nothing - , _selected = Nothing - , _time = Nothing - , _archiveUrl = Nothing - } - where - parseChk s = s == "yes" || s == "on" - --- API - -postAddR :: Handler () -postAddR = do - bookmarkForm <- requireCheckJsonBody - _handleFormSuccess bookmarkForm >>= \case - (Created, bid) -> sendStatusJSON created201 bid - (Updated, _) -> sendResponseStatus noContent204 () - -_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) - -postLookupTitleR :: Handler () -postLookupTitleR = do - void requireAuthId - bookmarkForm <- (requireCheckJsonBody :: Handler BookmarkForm) - fetchPageTitle (unpack (_url bookmarkForm)) >>= \case - Left _ -> sendResponseStatus noContent204 () - Right title -> sendResponseStatus ok200 title +module Handler.Add where + +import Import +import Handler.Archive +import Data.List (nub) +import qualified Data.Text as T (replace) + +-- View + +getAddViewR :: Handler Html +getAddViewR = do + userId <- requireAuthId + + murl <- lookupGetParam "url" + mformdb <- runDB (pure . fmap _toBookmarkForm =<< fetchBookmarkByUrl userId murl) + formurl <- bookmarkFormUrl + + let renderEl = "addForm" :: Text + + popupLayout do + toWidget [whamlet| +
+ |] + toWidgetBody [julius| + app.dat.bmark = #{ toJSON (fromMaybe formurl mformdb) }; + |] + toWidget [julius| + PS['Main'].renderAddForm('##{rawJS renderEl}')(app.dat.bmark)(); + |] + +bookmarkFormUrl :: Handler BookmarkForm +bookmarkFormUrl = do + Entity _ user <- requireAuth + url <- lookupGetParam "url" >>= pure . fromMaybe "" + title <- lookupGetParam "title" + description <- lookupGetParam "description" >>= pure . fmap Textarea + tags <- lookupGetParam "tags" + private <- lookupGetParam "private" >>= pure . fmap parseChk <&> (<|> Just (userPrivateDefault user)) + toread <- lookupGetParam "toread" >>= pure . fmap parseChk + pure $ + BookmarkForm + { _url = url + , _title = title + , _description = description + , _tags = tags + , _private = private + , _toread = toread + , _bid = Nothing + , _slug = Nothing + , _selected = Nothing + , _time = Nothing + , _archiveUrl = Nothing + } + where + parseChk s = s == "yes" || s == "on" + +-- API + +postAddR :: Handler () +postAddR = do + bookmarkForm <- requireCheckJsonBody + _handleFormSuccess bookmarkForm >>= \case + (Created, bid) -> sendStatusJSON created201 bid + (Updated, _) -> sendResponseStatus noContent204 () + +_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) + +postLookupTitleR :: Handler () +postLookupTitleR = do + void requireAuthId + bookmarkForm <- (requireCheckJsonBody :: Handler BookmarkForm) + fetchPageTitle (unpack (_url bookmarkForm)) >>= \case + Left _ -> sendResponseStatus noContent204 () + Right title -> sendResponseStatus ok200 title diff --git a/src/Handler/User.hs b/src/Handler/User.hs index 3ce12ff..606ec4f 100644 --- a/src/Handler/User.hs +++ b/src/Handler/User.hs @@ -1,154 +1,154 @@ -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -module Handler.User where - -import qualified Data.Text as T -import Handler.Common -import Import -import qualified Text.Blaze.Html5 as H -import Yesod.RssFeed -import qualified Database.Esqueleto as E -import qualified Data.Map as Map - -getUserR :: UserNameP -> Handler Html -getUserR uname@(UserNameP name) = do - _getUser uname SharedAll FilterAll (TagsP []) - -getUserSharedR :: UserNameP -> SharedP -> Handler Html -getUserSharedR uname sharedp = - _getUser uname sharedp FilterAll (TagsP []) - -getUserFilterR :: UserNameP -> FilterP -> Handler Html -getUserFilterR uname filterp = - _getUser uname SharedAll filterp (TagsP []) - -getUserTagsR :: UserNameP -> TagsP -> Handler Html -getUserTagsR uname pathtags = - _getUser uname SharedAll FilterAll pathtags - -_getUser :: UserNameP -> SharedP -> FilterP -> TagsP -> Handler Html -_getUser unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do - mauthuname <- maybeAuthUsername - (limit', page') <- lookupPagingParams - let limit = maybe 120 fromIntegral limit' - page = maybe 1 fromIntegral page' - isowner = maybe False (== uname) mauthuname - sharedp = if isowner then sharedp' else SharedPublic - filterp = case filterp' of - FilterSingle _ -> filterp' - _ -> if isowner then filterp' else FilterAll - isAll = filterp == FilterAll && sharedp == SharedAll && pathtags == [] - queryp = "query" :: Text - mquery <- lookupGetParam queryp - let mqueryp = fmap (\q -> (queryp, q)) mquery - (bcount, bmarks, alltags) <- - runDB $ - do Entity userId user <- getBy404 (UniqueUserName uname) - when (not isowner && userPrivacyLock user) - (redirect (AuthR LoginR)) - (cnt, bm) <- bookmarksQuery userId sharedp filterp pathtags mquery limit page - tg <- tagsQuery bm - pure (cnt, bm, tg) - when (bcount == 0) (case filterp of FilterSingle _ -> notFound; _ -> pure ()) - mroute <- getCurrentRoute - tagCloudMode <- getTagCloudMode isowner pathtags - req <- getRequest - defaultLayout do - let pager = $(widgetFile "pager") - search = $(widgetFile "search") - renderEl = "bookmarks" :: Text - tagCloudRenderEl = "tagCloud" :: Text - rssLink (UserFeedR unamep) "feed" - $(widgetFile "user") - toWidgetBody [julius| - app.dat.bmarks = #{ toJSON $ toBookmarkFormList bmarks alltags } || []; - app.dat.isowner = #{ isowner }; - app.userR = "@{UserR unamep}"; - app.tagCloudMode = #{ toJSON $ tagCloudMode } || {}; - |] - toWidget [julius| - PS['Main'].renderTagCloud('##{rawJS tagCloudRenderEl}')(app.tagCloudMode)(); - PS['Main'].renderBookmarks('##{rawJS renderEl}')(app.dat.bmarks)(); - |] - --- Form - -postUserTagCloudR :: Handler () -postUserTagCloudR = do - userId <- requireAuthId - mode <- requireCheckJsonBody - _updateTagCloudMode mode - tc <- runDB $ case mode of - TagCloudModeTop _ n -> tagCountTop userId n - TagCloudModeLowerBound _ n -> tagCountLowerBound userId n - TagCloudModeRelated _ tags -> tagCountRelated userId tags - TagCloudModeNone -> notFound - sendStatusJSON ok200 (Map.fromList tc :: Map.Map Text Int) - -postUserTagCloudModeR :: Handler () -postUserTagCloudModeR = do - userId <- requireAuthId - mode <- requireCheckJsonBody - _updateTagCloudMode mode - -_updateTagCloudMode :: TagCloudMode -> Handler () -_updateTagCloudMode mode = - case mode of - TagCloudModeTop _ _ -> setTagCloudMode mode - TagCloudModeLowerBound _ _ -> setTagCloudMode mode - TagCloudModeRelated _ _ -> setTagCloudMode mode - TagCloudModeNone -> notFound - -bookmarkToRssEntry :: (Entity Bookmark, [Text]) -> FeedEntry Text -bookmarkToRssEntry ((Entity entryId entry), tags) = - FeedEntry - { feedEntryLink = bookmarkHref entry - , feedEntryUpdated = bookmarkTime entry - , feedEntryTitle = bookmarkDescription entry - , feedEntryContent = toHtml (bookmarkExtended entry) - , feedEntryCategories = map (EntryCategory Nothing Nothing) tags - , feedEntryEnclosure = Nothing - } - -toBookmarkWithTagsList :: [Entity Bookmark] -> [Entity BookmarkTag] -> [(Entity Bookmark, [Text])] -toBookmarkWithTagsList bs as = do - b <- bs - let bid = E.entityKey b - let btags = filter ((==) bid . bookmarkTagBookmarkId . E.entityVal) as - pure $ (b, map (bookmarkTagTag . E.entityVal) btags) - -getUserFeedR :: UserNameP -> Handler RepRss -getUserFeedR unamep@(UserNameP uname) = do - mauthuname <- maybeAuthUsername - (limit', page') <- lookupPagingParams - let limit = maybe 120 fromIntegral limit' - page = maybe 1 fromIntegral page' - queryp = "query" :: Text - isowner = maybe False (== uname) mauthuname - mquery <- lookupGetParam queryp - (_, bmarks, alltags) <- - runDB $ - do Entity userId user <- getBy404 (UniqueUserName uname) - when (not isowner && userPrivacyLock user) - (redirect (AuthR LoginR)) - (cnt, bm) <- bookmarksQuery userId SharedPublic FilterAll [] mquery limit page - tg <- tagsQuery bm - pure (cnt, bm, tg) - let (descr :: Html) = toHtml $ H.text ("Bookmarks saved by " <> uname) - entriesWithTags = toBookmarkWithTagsList bmarks alltags - entries = map bookmarkToRssEntry entriesWithTags - updated <- case maximumMay (map feedEntryUpdated entries) of - Nothing -> liftIO $ getCurrentTime - Just m -> return m - render <- getUrlRender - rssFeedText $ - Feed - { feedTitle = "espial " <> uname - , feedLinkSelf = render (UserFeedR unamep) - , feedLinkHome = render (UserR unamep) - , feedAuthor = uname - , feedDescription = descr - , feedLanguage = "en" - , feedUpdated = updated - , feedLogo = Nothing - , feedEntries = entries - } +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +module Handler.User where + +import qualified Data.Text as T +import Handler.Common +import Import +import qualified Text.Blaze.Html5 as H +import Yesod.RssFeed +import qualified Database.Esqueleto as E +import qualified Data.Map as Map + +getUserR :: UserNameP -> Handler Html +getUserR uname@(UserNameP name) = do + _getUser uname SharedAll FilterAll (TagsP []) + +getUserSharedR :: UserNameP -> SharedP -> Handler Html +getUserSharedR uname sharedp = + _getUser uname sharedp FilterAll (TagsP []) + +getUserFilterR :: UserNameP -> FilterP -> Handler Html +getUserFilterR uname filterp = + _getUser uname SharedAll filterp (TagsP []) + +getUserTagsR :: UserNameP -> TagsP -> Handler Html +getUserTagsR uname pathtags = + _getUser uname SharedAll FilterAll pathtags + +_getUser :: UserNameP -> SharedP -> FilterP -> TagsP -> Handler Html +_getUser unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do + mauthuname <- maybeAuthUsername + (limit', page') <- lookupPagingParams + let limit = maybe 120 fromIntegral limit' + page = maybe 1 fromIntegral page' + isowner = maybe False (== uname) mauthuname + sharedp = if isowner then sharedp' else SharedPublic + filterp = case filterp' of + FilterSingle _ -> filterp' + _ -> if isowner then filterp' else FilterAll + isAll = filterp == FilterAll && sharedp == SharedAll && pathtags == [] + queryp = "query" :: Text + mquery <- lookupGetParam queryp + let mqueryp = fmap (\q -> (queryp, q)) mquery + (bcount, bmarks, alltags) <- + runDB $ + do Entity userId user <- getBy404 (UniqueUserName uname) + when (not isowner && userPrivacyLock user) + (redirect (AuthR LoginR)) + (cnt, bm) <- bookmarksQuery userId sharedp filterp pathtags mquery limit page + tg <- tagsQuery bm + pure (cnt, bm, tg) + when (bcount == 0) (case filterp of FilterSingle _ -> notFound; _ -> pure ()) + mroute <- getCurrentRoute + tagCloudMode <- getTagCloudMode isowner pathtags + req <- getRequest + defaultLayout do + let pager = $(widgetFile "pager") + search = $(widgetFile "search") + renderEl = "bookmarks" :: Text + tagCloudRenderEl = "tagCloud" :: Text + rssLink (UserFeedR unamep) "feed" + $(widgetFile "user") + toWidgetBody [julius| + app.dat.bmarks = #{ toJSON $ toBookmarkFormList bmarks alltags } || []; + app.dat.isowner = #{ isowner }; + app.userR = "@{UserR unamep}"; + app.tagCloudMode = #{ toJSON $ tagCloudMode } || {}; + |] + toWidget [julius| + PS['Main'].renderTagCloud('##{rawJS tagCloudRenderEl}')(app.tagCloudMode)(); + PS['Main'].renderBookmarks('##{rawJS renderEl}')(app.dat.bmarks)(); + |] + +-- Form + +postUserTagCloudR :: Handler () +postUserTagCloudR = do + userId <- requireAuthId + mode <- requireCheckJsonBody + _updateTagCloudMode mode + tc <- runDB $ case mode of + TagCloudModeTop _ n -> tagCountTop userId n + TagCloudModeLowerBound _ n -> tagCountLowerBound userId n + TagCloudModeRelated _ tags -> tagCountRelated userId tags + TagCloudModeNone -> notFound + sendStatusJSON ok200 (Map.fromList tc :: Map.Map Text Int) + +postUserTagCloudModeR :: Handler () +postUserTagCloudModeR = do + userId <- requireAuthId + mode <- requireCheckJsonBody + _updateTagCloudMode mode + +_updateTagCloudMode :: TagCloudMode -> Handler () +_updateTagCloudMode mode = + case mode of + TagCloudModeTop _ _ -> setTagCloudMode mode + TagCloudModeLowerBound _ _ -> setTagCloudMode mode + TagCloudModeRelated _ _ -> setTagCloudMode mode + TagCloudModeNone -> notFound + +bookmarkToRssEntry :: (Entity Bookmark, [Text]) -> FeedEntry Text +bookmarkToRssEntry ((Entity entryId entry), tags) = + FeedEntry + { feedEntryLink = bookmarkHref entry + , feedEntryUpdated = bookmarkTime entry + , feedEntryTitle = bookmarkDescription entry + , feedEntryContent = toHtml (bookmarkExtended entry) + , feedEntryCategories = map (EntryCategory Nothing Nothing) tags + , feedEntryEnclosure = Nothing + } + +toBookmarkWithTagsList :: [Entity Bookmark] -> [Entity BookmarkTag] -> [(Entity Bookmark, [Text])] +toBookmarkWithTagsList bs as = do + b <- bs + let bid = E.entityKey b + let btags = filter ((==) bid . bookmarkTagBookmarkId . E.entityVal) as + pure $ (b, map (bookmarkTagTag . E.entityVal) btags) + +getUserFeedR :: UserNameP -> Handler RepRss +getUserFeedR unamep@(UserNameP uname) = do + mauthuname <- maybeAuthUsername + (limit', page') <- lookupPagingParams + let limit = maybe 120 fromIntegral limit' + page = maybe 1 fromIntegral page' + queryp = "query" :: Text + isowner = maybe False (== uname) mauthuname + mquery <- lookupGetParam queryp + (_, bmarks, alltags) <- + runDB $ + do Entity userId user <- getBy404 (UniqueUserName uname) + when (not isowner && userPrivacyLock user) + (redirect (AuthR LoginR)) + (cnt, bm) <- bookmarksQuery userId SharedPublic FilterAll [] mquery limit page + tg <- tagsQuery bm + pure (cnt, bm, tg) + let (descr :: Html) = toHtml $ H.text ("Bookmarks saved by " <> uname) + entriesWithTags = toBookmarkWithTagsList bmarks alltags + entries = map bookmarkToRssEntry entriesWithTags + updated <- case maximumMay (map feedEntryUpdated entries) of + Nothing -> liftIO $ getCurrentTime + Just m -> return m + render <- getUrlRender + rssFeedText $ + Feed + { feedTitle = "espial " <> uname + , feedLinkSelf = render (UserFeedR unamep) + , feedLinkHome = render (UserR unamep) + , feedAuthor = uname + , feedDescription = descr + , feedLanguage = "en" + , feedUpdated = updated + , feedLogo = Nothing + , feedEntries = entries + } diff --git a/src/Model.hs b/src/Model.hs index 660d5e8..b35b520 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -1,848 +1,848 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Model where - -import qualified ClassyPrelude.Yesod as CP -import Control.Monad.Fail (MonadFail) -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A (parseFail) -import qualified Data.Attoparsec.Text as P -import qualified Control.Monad.Combinators as PC -import qualified Data.List.NonEmpty as NE -import qualified Data.Time.ISO8601 as TI -import qualified Data.Time.Clock.POSIX as TI -import qualified Database.Esqueleto as E -import Database.Esqueleto.Internal.Sql as E -import qualified Data.Time as TI -import ClassyPrelude.Yesod hiding ((||.)) -import Control.Monad.Trans.Maybe -import Control.Monad.Writer (tell) -import Data.Char (isSpace) -import Data.Either (fromRight) -import Data.Foldable (foldl, foldl1, sequenceA_) -import Data.List.NonEmpty (NonEmpty(..)) -import Database.Esqueleto hiding ((==.)) -import Pretty -import System.Directory -import Types -import qualified Data.Map.Strict as MS - -import ModelCustom - -share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase| -User json - Id Int64 - name Text - passwordHash BCrypt - apiToken Text Maybe - privateDefault Bool - archiveDefault Bool - privacyLock Bool - UniqueUserName name - deriving Show Eq Typeable Ord - -Bookmark json - Id Int64 - userId UserId - slug BmSlug default="(lower(hex(randomblob(6))))" - href Text - description Text - extended Text - time UTCTime - shared Bool - toRead Bool - selected Bool - archiveHref Text Maybe - UniqueUserHref userId href - UniqueUserSlug userId slug - deriving Show Eq Typeable Ord - -BookmarkTag json - Id Int64 - userId UserId - tag Text - bookmarkId BookmarkId - seq Int - UniqueUserTagBookmarkId userId tag bookmarkId - UniqueUserBookmarkIdTagSeq userId bookmarkId tag seq - deriving Show Eq Typeable Ord - -Note json - Id Int64 - userId UserId - slug NtSlug default="(lower(hex(randomblob(10))))" - length Int - title Text - text Text - isMarkdown Bool - shared Bool default=False - created UTCTime - updated UTCTime - deriving Show Eq Typeable Ord -|] - -newtype UTCTimeStr = - UTCTimeStr { unUTCTimeStr :: UTCTime } - deriving (Eq, Show, Read, Generic, FromJSON, ToJSON) - -instance PathPiece UTCTimeStr where - toPathPiece (UTCTimeStr u) = pack (TI.formatISO8601Millis u) - fromPathPiece s = UTCTimeStr <$> TI.parseISO8601 (unpack s) - -newtype UserNameP = - UserNameP { unUserNameP :: Text } - deriving (Eq, Show, Read) - -newtype TagsP = - TagsP { unTagsP :: [Text] } - deriving (Eq, Show, Read) - -data SharedP - = SharedAll - | SharedPublic - | SharedPrivate - deriving (Eq, Show, Read) - -data FilterP - = FilterAll - | FilterUnread - | FilterUntagged - | FilterStarred - | FilterSingle BmSlug - deriving (Eq, Show, Read) - -newtype UnreadOnly = - UnreadOnly { unUnreadOnly :: Bool } - - deriving (Eq, Show, Read) - -type Limit = Int64 -type Page = Int64 - -migrateAll :: Migration -migrateAll = migrateSchema >> migrateIndexes - -dumpMigration :: DB () -dumpMigration = printMigration migrateAll - -runMigrations :: DB () -runMigrations = runMigration migrateAll - -toMigration :: [Text] -> Migration -toMigration = lift . tell . fmap (False ,) - -migrateIndexes :: Migration -migrateIndexes = - toMigration - [ "CREATE INDEX IF NOT EXISTS idx_bookmark_time ON bookmark (user_id, time DESC)" - , "CREATE INDEX IF NOT EXISTS idx_bookmark_tag_bookmark_id ON bookmark_tag (bookmark_id, id, tag, seq)" - , "CREATE INDEX IF NOT EXISTS idx_note_user_created ON note (user_id, created DESC)" - ] - -sqlite_group_concat :: - PersistField a - => SqlExpr (E.Value a) - -> SqlExpr (E.Value a) - -> SqlExpr (E.Value Text) -sqlite_group_concat expr sep = E.unsafeSqlFunction "GROUP_CONCAT" [expr, sep] - -authenticatePassword :: Text -> Text -> DB (Maybe (Entity User)) -authenticatePassword username password = do - muser <- getBy (UniqueUserName username) - case muser of - Nothing -> return Nothing - Just dbuser -> - if validatePasswordHash (userPasswordHash (entityVal dbuser)) password - then return (Just dbuser) - else return Nothing - -getUserByName :: UserNameP -> DB (Maybe (Entity User)) -getUserByName (UserNameP uname) = do - selectFirst [UserName ==. uname] [] - -bookmarksQuery - :: Key User - -> SharedP - -> FilterP - -> [Tag] - -> Maybe Text - -> Limit - -> Page - -> DB (Int, [Entity Bookmark]) -bookmarksQuery userId sharedp filterp tags mquery limit' page = - (,) -- total count - <$> fmap (sum . fmap E.unValue) - (select $ - from \b -> do - _whereClause b - pure E.countRows) - -- paged data - <*> (select $ - from \b -> do - _whereClause b - orderBy [desc (b ^. BookmarkTime)] - limit limit' - offset ((page - 1) * limit') - pure b) - where - _whereClause b = do - where_ $ - foldl (\expr tag -> - expr &&. (exists $ -- each tag becomes an exists constraint - from \t -> - where_ (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId &&. - (t ^. BookmarkTagTag `E.like` val tag)))) - (b ^. BookmarkUserId E.==. val userId) - tags - case sharedp of - SharedAll -> pure () - SharedPublic -> where_ (b ^. BookmarkShared E.==. val True) - SharedPrivate -> where_ (b ^. BookmarkShared E.==. val False) - case filterp of - FilterAll -> pure () - FilterUnread -> where_ (b ^. BookmarkToRead E.==. val True) - FilterStarred -> where_ (b ^. BookmarkSelected E.==. val True) - FilterSingle slug -> where_ (b ^. BookmarkSlug E.==. val slug) - FilterUntagged -> where_ $ notExists $ from (\t -> where_ $ - (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId)) - -- search - sequenceA_ (parseSearchQuery (toLikeExpr b) =<< mquery) - - toLikeExpr :: E.SqlExpr (Entity Bookmark) -> Text -> E.SqlExpr (E.Value Bool) - toLikeExpr b term = fromRight p_allFields (P.parseOnly p_onefield term) - where - wild s = (E.%) ++. val s ++. (E.%) - toLikeB field s = b ^. field `E.like` wild s - p_allFields = - (toLikeB BookmarkHref term) ||. - (toLikeB BookmarkDescription term) ||. - (toLikeB BookmarkExtended term) ||. - (exists $ from (\t -> where_ $ - (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId) &&. - (t ^. BookmarkTagTag `E.like` (wild term)))) - p_onefield = p_url <|> p_title <|> p_description <|> p_tags <|> p_after <|> p_before - where - p_url = "url:" *> fmap (toLikeB BookmarkHref) P.takeText - p_title = "title:" *> fmap (toLikeB BookmarkDescription) P.takeText - p_description = "description:" *> fmap (toLikeB BookmarkExtended) P.takeText - p_tags = "tags:" *> fmap (\term' -> exists $ from (\t -> where_ $ - (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId) &&. - (t ^. BookmarkTagTag `E.like` wild term'))) P.takeText - p_after = "after:" *> fmap ((b ^. BookmarkTime E.>=.) . val) (parseTimeText =<< P.takeText) - p_before = "before:" *> fmap ((b ^. BookmarkTime E.<=.) . val) (parseTimeText =<< P.takeText) - -parseSearchQuery :: - (Text -> E.SqlExpr (E.Value Bool)) - -> Text - -> Maybe (E.SqlQuery ()) -parseSearchQuery toExpr = - fmap where_ . either (const Nothing) Just . P.parseOnly andE - where - andE = foldl1 (&&.) <$> P.many1 (P.skipSpace *> orE <|> tokenTermE) - orE = foldl1 (||.) <$> tokenTermE `P.sepBy1` P.char '|' - tokenTermE = negE termE <|> termE - where - negE p = not_ <$> (P.char '-' *> p) - termE = toExpr <$> (fieldTerm <|> quotedTerm <|> simpleTerm) - fieldTerm = concat <$> sequence [simpleTerm, P.string ":", quotedTerm <|> simpleTerm] - quotedTerm = PC.between (P.char '"') (P.char '"') (P.takeWhile1 (/= '"')) - simpleTerm = P.takeWhile1 (\c -> not (isSpace c) && c /= ':' && c /= '|') - -parseTimeText :: (TI.ParseTime t, MonadFail m, Alternative m) => Text -> m t -parseTimeText t = - asum $ - flip (parseTimeM True defaultTimeLocale) (unpack t) <$> - [ "%-m/%-d/%Y" , "%-m/%-d/%Y%z" , "%-m/%-d/%Y%Z" -- 12/31/2018 - , "%Y-%-m-%-d" , "%Y-%-m-%-d%z" , "%Y-%-m-%-d%Z" -- 2018-12-31 - , "%Y-%-m-%-dT%T" , "%Y-%-m-%-dT%T%z" , "%Y-%-m-%-dT%T%Z" -- 2018-12-31T06:40:53 - , "%s" -- 1535932800 - ] - -tagsQuery :: [Entity Bookmark] -> DB [Entity BookmarkTag] -tagsQuery bmarks = - select $ - from \t -> do - where_ (t ^. BookmarkTagBookmarkId `in_` valList (fmap entityKey bmarks)) - orderBy [asc (t ^. BookmarkTagSeq)] - pure t - -withTags :: Key Bookmark -> DB [Entity BookmarkTag] -withTags key = selectList [BookmarkTagBookmarkId ==. key] [Asc BookmarkTagSeq] - --- Note List Query - - -getNote :: Key User -> NtSlug -> DB (Maybe (Entity Note)) -getNote userKey slug = - selectFirst [NoteUserId ==. userKey, NoteSlug ==. slug] [] - -getNoteList :: Key User -> Maybe Text -> SharedP -> Limit -> Page -> DB (Int, [Entity Note]) -getNoteList key mquery sharedp limit' page = - (,) -- total count - <$> fmap (sum . fmap E.unValue) - (select $ - from \b -> do - _whereClause b - pure $ E.countRows) - <*> (select $ - from \b -> do - _whereClause b - orderBy [desc (b ^. NoteCreated)] - limit limit' - offset ((page - 1) * limit') - pure b) - where - _whereClause b = do - where_ $ (b ^. NoteUserId E.==. val key) - -- search - sequenceA_ (parseSearchQuery (toLikeExpr b) =<< mquery) - case sharedp of - SharedAll -> pure () - SharedPublic -> where_ (b ^. NoteShared E.==. val True) - SharedPrivate -> where_ (b ^. NoteShared E.==. val False) - - toLikeExpr :: E.SqlExpr (Entity Note) -> Text -> E.SqlExpr (E.Value Bool) - toLikeExpr b term = fromRight p_allFields (P.parseOnly p_onefield term) - where - wild s = (E.%) ++. val s ++. (E.%) - toLikeN field s = b ^. field `E.like` wild s - p_allFields = toLikeN NoteTitle term ||. toLikeN NoteText term - p_onefield = p_title <|> p_text <|> p_after <|> p_before - where - p_title = "title:" *> fmap (toLikeN NoteTitle) P.takeText - p_text = "description:" *> fmap (toLikeN NoteText) P.takeText - p_after = "after:" *> fmap ((b ^. NoteCreated E.>=.) . val) (parseTimeText =<< P.takeText) - p_before = "before:" *> fmap ((b ^. NoteCreated E.<=.) . val) (parseTimeText =<< P.takeText) - --- Bookmark Files - -mkBookmarkTags :: Key User -> Key Bookmark -> [Tag] -> [BookmarkTag] -mkBookmarkTags userId bookmarkId tags = - (\(i, tag) -> BookmarkTag userId tag bookmarkId i) <$> zip [1 ..] tags - - -fileBookmarkToBookmark :: UserId -> FileBookmark -> IO Bookmark -fileBookmarkToBookmark user (FileBookmark {..}) = do - slug <- mkBmSlug - pure $ - Bookmark - { bookmarkUserId = user - , bookmarkSlug = slug - , bookmarkHref = fileBookmarkHref - , bookmarkDescription = fileBookmarkDescription - , bookmarkExtended = fileBookmarkExtended - , bookmarkTime = fileBookmarkTime - , bookmarkShared = fileBookmarkShared - , bookmarkToRead = fileBookmarkToRead - , bookmarkSelected = (fromMaybe False fileBookmarkSelected) - , bookmarkArchiveHref = fileBookmarkArchiveHref - } - -bookmarkTofileBookmark :: Bookmark -> Text -> FileBookmark -bookmarkTofileBookmark (Bookmark {..}) tags = - FileBookmark - { fileBookmarkHref = bookmarkHref - , fileBookmarkDescription = bookmarkDescription - , fileBookmarkExtended = bookmarkExtended - , fileBookmarkTime = bookmarkTime - , fileBookmarkShared = bookmarkShared - , fileBookmarkToRead = bookmarkToRead - , fileBookmarkSelected = Just bookmarkSelected - , fileBookmarkArchiveHref = bookmarkArchiveHref - , fileBookmarkTags = tags - } - -data FFBookmarkNode = FFBookmarkNode - { firefoxBookmarkChildren :: Maybe [FFBookmarkNode] - , firefoxBookmarkDateAdded :: !TI.POSIXTime - , firefoxBookmarkGuid :: !Text - , firefoxBookmarkIconUri :: !(Maybe Text) - , firefoxBookmarkId :: !Int - , firefoxBookmarkIndex :: !Int - , firefoxBookmarkLastModified :: !TI.POSIXTime - , firefoxBookmarkRoot :: !(Maybe Text) - , firefoxBookmarkTitle :: !Text - , firefoxBookmarkType :: !Text - , firefoxBookmarkTypeCode :: !Int - , firefoxBookmarkUri :: !(Maybe Text) - } deriving (Show, Eq, Typeable, Ord) - -instance FromJSON FFBookmarkNode where - parseJSON (Object o) = - FFBookmarkNode <$> - (o A..:? "children") <*> - (o .: "dateAdded") <*> - o .: "guid" <*> - (o A..:? "iconUri") <*> - o .: "id" <*> - o .: "index" <*> - (o .: "lastModified") <*> - (o A..:? "root") <*> - (o .: "title") <*> - (o .: "type") <*> - (o .: "typeCode") <*> - (o A..:? "uri") - parseJSON _ = A.parseFail "bad parse" - -firefoxBookmarkNodeToBookmark :: UserId -> FFBookmarkNode -> IO [Bookmark] -firefoxBookmarkNodeToBookmark user (FFBookmarkNode {..}) = do - case firefoxBookmarkTypeCode of - 1 -> do - slug <- mkBmSlug - pure $ - [ Bookmark - { bookmarkUserId = user - , bookmarkSlug = slug - , bookmarkHref = (fromMaybe "" firefoxBookmarkUri) - , bookmarkDescription = firefoxBookmarkTitle - , bookmarkExtended = "" - , bookmarkTime = (TI.posixSecondsToUTCTime (firefoxBookmarkDateAdded / 1000000)) - , bookmarkShared = True - , bookmarkToRead = False - , bookmarkSelected = False - , bookmarkArchiveHref = Nothing - } - ] - 2 -> - join <$> - mapM - (firefoxBookmarkNodeToBookmark user) - (fromMaybe [] firefoxBookmarkChildren) - _ -> pure [] - - -insertFileBookmarks :: Key User -> FilePath -> DB (Either String Int) -insertFileBookmarks userId bookmarkFile = do - mfmarks <- liftIO $ readFileBookmarks bookmarkFile - case mfmarks of - Left e -> pure $ Left e - Right fmarks -> do - bmarks <- liftIO $ mapM (fileBookmarkToBookmark userId) fmarks - mbids <- mapM insertUnique bmarks - void $ - mapM insertUnique $ - concatMap (uncurry (mkBookmarkTags userId)) $ - catMaybes $ - zipWith - (\mbid tags -> ((, tags) <$> mbid)) - mbids - (extractTags <$> fmarks) - pure $ Right (length bmarks) - - where - extractTags = words . fileBookmarkTags - -insertFFBookmarks :: Key User -> FilePath -> DB (Either String Int) -insertFFBookmarks userId bookmarkFile = do - mfmarks <- liftIO $ readFFBookmarks bookmarkFile - case mfmarks of - Left e -> pure $ Left e - Right fmarks -> do - bmarks <- liftIO $ firefoxBookmarkNodeToBookmark userId fmarks - _ <- mapM insertUnique bmarks - pure $ Right (length bmarks) - - -readFileBookmarks :: MonadIO m => FilePath -> m (Either String [FileBookmark]) -readFileBookmarks fpath = - pure . A.eitherDecode' . fromStrict =<< readFile fpath - -readFFBookmarks :: MonadIO m => FilePath -> m (Either String FFBookmarkNode) -readFFBookmarks fpath = - pure . A.eitherDecode' . fromStrict =<< readFile fpath - -exportFileBookmarks :: Key User -> FilePath -> DB () -exportFileBookmarks user fpath = do - liftIO . A.encodeFile fpath =<< getFileBookmarks user - -getFileBookmarks :: Key User -> DB [FileBookmark] -getFileBookmarks user = do - marks <- allUserBookmarks user - pure $ fmap (\(bm, t) -> bookmarkTofileBookmark (entityVal bm) t) marks - --- returns a list of pair of bookmark with tags merged into a string -allUserBookmarks :: Key User -> DB [(Entity Bookmark, Text)] -allUserBookmarks user = do - bmarks <- bquery - tags <- tquery - let tagmap = MS.fromList tags - pure $ (\bm@(Entity bid _) -> (bm, findWithDefault mempty bid tagmap)) <$> bmarks - where - bquery :: DB [Entity Bookmark] - bquery = - select $ - from \b -> do - where_ (b ^. BookmarkUserId E.==. val user) - orderBy [asc (b ^. BookmarkTime)] - pure b - tquery :: DB [(Key Bookmark, Text)] - tquery = - fmap (\(tid, tags) -> (E.unValue tid, E.unValue tags)) <$> - (select $ - from \t -> do - where_ (t ^. BookmarkTagUserId E.==. val user) - E.groupBy (t ^. BookmarkTagBookmarkId) - let tags = sqlite_group_concat (t ^. BookmarkTagTag) (E.val " ") - pure (t ^. BookmarkTagBookmarkId, tags)) - - -data TagCloudMode - = TagCloudModeTop Bool Int -- { mode: "top", value: 200 } - | TagCloudModeLowerBound Bool Int -- { mode: "lowerBound", value: 20 } - | TagCloudModeRelated Bool [Tag] - | TagCloudModeNone - deriving (Show, Eq, Read, Generic) - -isExpanded :: TagCloudMode -> Bool -isExpanded (TagCloudModeTop e _) = e -isExpanded (TagCloudModeLowerBound e _) = e -isExpanded (TagCloudModeRelated e _) = e -isExpanded TagCloudModeNone = False - -instance FromJSON TagCloudMode where - parseJSON (Object o) = - case lookup "mode" o of - Just (String "top") -> TagCloudModeTop <$> o .: "expanded" <*> o .: "value" - Just (String "lowerBound") -> TagCloudModeLowerBound <$> o .: "expanded" <*> o .: "value" - Just (String "related") -> TagCloudModeRelated <$> o .: "expanded" <*> (fmap words (o .: "value")) - Just (String "none") -> pure TagCloudModeNone - _ -> A.parseFail "bad parse" - parseJSON _ = A.parseFail "bad parse" - -instance ToJSON TagCloudMode where - toJSON (TagCloudModeTop e i) = - object [ "mode" .= String "top" - , "value" .= toJSON i - , "expanded" .= Bool e - ] - toJSON (TagCloudModeLowerBound e i) = - object [ "mode" .= String "lowerBound" - , "value" .= toJSON i - , "expanded" .= Bool e - ] - toJSON (TagCloudModeRelated e tags) = - object [ "mode" .= String "related" - , "value" .= String (unwords tags) - , "expanded" .= Bool e - ] - toJSON TagCloudModeNone = - object [ "mode" .= String "none" - , "value" .= Null - , "expanded" .= Bool False - ] - - -type Tag = Text - -tagCountTop :: Key User -> Int -> DB [(Text, Int)] -tagCountTop user top = - sortOn (toLower . fst) . - fmap (\(tname, tcount) -> (E.unValue tname, E.unValue tcount)) <$> - ( select $ - from \t -> do - where_ (t ^. BookmarkTagUserId E.==. val user) - E.groupBy (E.lower_ $ t ^. BookmarkTagTag) - let countRows' = E.countRows - E.orderBy [E.desc countRows'] - E.limit ((fromIntegral . toInteger) top) - pure $ (t ^. BookmarkTagTag, countRows') - ) - -tagCountLowerBound :: Key User -> Int -> DB [(Text, Int)] -tagCountLowerBound user lowerBound = - fmap (\(tname, tcount) -> (E.unValue tname, E.unValue tcount)) <$> - ( select $ - from \t -> do - where_ (t ^. BookmarkTagUserId E.==. val user) - E.groupBy (E.lower_ $ t ^. BookmarkTagTag) - let countRows' = E.countRows - E.orderBy [E.asc (t ^. BookmarkTagTag)] - E.having (countRows' E.>=. E.val lowerBound) - pure $ (t ^. BookmarkTagTag, countRows') - ) - -tagCountRelated :: Key User -> [Tag] -> DB [(Text, Int)] -tagCountRelated user tags = - fmap (\(tname, tcount) -> (E.unValue tname, E.unValue tcount)) <$> - ( select $ - from \t -> do - where_ $ - foldl (\expr tag -> - expr &&. (exists $ - from \u -> - where_ (u ^. BookmarkTagBookmarkId E.==. t ^. BookmarkTagBookmarkId &&. - (u ^. BookmarkTagTag `E.like` val tag)))) - (t ^. BookmarkTagUserId E.==. val user) - tags - E.groupBy (E.lower_ $ t ^. BookmarkTagTag) - let countRows' = E.countRows - E.orderBy [E.asc $ E.lower_ $ (t ^. BookmarkTagTag)] - pure $ (t ^. BookmarkTagTag, countRows') - ) - --- Notes - -fileNoteToNote :: UserId -> FileNote -> IO Note -fileNoteToNote user (FileNote {..} ) = do - slug <- mkNtSlug - pure $ - Note - { noteUserId = user - , noteSlug = slug - , noteLength = fileNoteLength - , noteTitle = fileNoteTitle - , noteText = fileNoteText - , noteIsMarkdown = False - , noteShared = False - , noteCreated = fileNoteCreatedAt - , noteUpdated = fileNoteUpdatedAt - } - -insertDirFileNotes :: Key User -> FilePath -> DB (Either String Int) -insertDirFileNotes userId noteDirectory = do - mfnotes <- liftIO $ readFileNotes noteDirectory - case mfnotes of - Left e -> pure $ Left e - Right fnotes -> do - notes <- liftIO $ mapM (fileNoteToNote userId) fnotes - void $ mapM insertUnique notes - pure $ Right (length notes) - where - readFileNotes :: MonadIO m => FilePath -> m (Either String [FileNote]) - readFileNotes fdir = do - files <- liftIO (listDirectory fdir) - noteBSS <- mapM (readFile . (fdir )) files - pure (mapM (A.eitherDecode' . fromStrict) noteBSS) - --- AccountSettingsForm -data AccountSettingsForm = AccountSettingsForm - { _privateDefault :: Bool - , _archiveDefault :: Bool - , _privacyLock :: Bool - } deriving (Show, Eq, Read, Generic) - -instance FromJSON AccountSettingsForm where parseJSON = A.genericParseJSON gDefaultFormOptions -instance ToJSON AccountSettingsForm where toJSON = A.genericToJSON gDefaultFormOptions - -toAccountSettingsForm :: User -> AccountSettingsForm -toAccountSettingsForm (User {..}) = - AccountSettingsForm - { _privateDefault = userPrivateDefault - , _archiveDefault = userArchiveDefault - , _privacyLock = userPrivacyLock - } - -updateUserFromAccountSettingsForm :: Key User -> AccountSettingsForm -> DB () -updateUserFromAccountSettingsForm userId (AccountSettingsForm {..}) = do - CP.update userId - [ UserPrivateDefault CP.=. _privateDefault - , UserArchiveDefault CP.=. _archiveDefault - , UserPrivacyLock CP.=. _privacyLock - ] - --- BookmarkForm - -data BookmarkForm = BookmarkForm - { _url :: Text - , _title :: Maybe Text - , _description :: Maybe Textarea - , _tags :: Maybe Text - , _private :: Maybe Bool - , _toread :: Maybe Bool - , _bid :: Maybe Int64 - , _slug :: Maybe BmSlug - , _selected :: Maybe Bool - , _time :: Maybe UTCTimeStr - , _archiveUrl :: Maybe Text - } deriving (Show, Eq, Read, Generic) - -instance FromJSON BookmarkForm where parseJSON = A.genericParseJSON gDefaultFormOptions -instance ToJSON BookmarkForm where toJSON = A.genericToJSON gDefaultFormOptions - -gDefaultFormOptions :: A.Options -gDefaultFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 } - -toBookmarkFormList :: [Entity Bookmark] -> [Entity BookmarkTag] -> [BookmarkForm] -toBookmarkFormList bs as = do - b <- bs - let bid = E.entityKey b - let btags = filter ((==) bid . bookmarkTagBookmarkId . E.entityVal) as - pure $ _toBookmarkForm (b, btags) - -_toBookmarkForm :: (Entity Bookmark, [Entity BookmarkTag]) -> BookmarkForm -_toBookmarkForm (Entity bid Bookmark {..}, tags) = - BookmarkForm - { _url = bookmarkHref - , _title = Just bookmarkDescription - , _description = Just $ Textarea $ bookmarkExtended - , _tags = Just $ unwords $ fmap (bookmarkTagTag . entityVal) tags - , _private = Just $ not bookmarkShared - , _toread = Just $ bookmarkToRead - , _bid = Just $ unBookmarkKey $ bid - , _slug = Just $ bookmarkSlug - , _selected = Just $ bookmarkSelected - , _time = Just $ UTCTimeStr $ bookmarkTime - , _archiveUrl = bookmarkArchiveHref - } - -_toBookmark :: UserId -> BookmarkForm -> IO Bookmark -_toBookmark userId BookmarkForm {..} = do - time <- liftIO getCurrentTime - slug <- maybe mkBmSlug pure _slug - pure $ - Bookmark - { bookmarkUserId = userId - , bookmarkSlug = slug - , bookmarkHref = _url - , bookmarkDescription = fromMaybe "" _title - , bookmarkExtended = maybe "" unTextarea _description - , bookmarkTime = fromMaybe time (fmap unUTCTimeStr _time) - , bookmarkShared = maybe True not _private - , bookmarkToRead = fromMaybe False _toread - , bookmarkSelected = fromMaybe False _selected - , bookmarkArchiveHref = _archiveUrl - } - -fetchBookmarkByUrl :: Key User -> Maybe Text -> DB (Maybe (Entity Bookmark, [Entity BookmarkTag])) -fetchBookmarkByUrl userId murl = runMaybeT do - bmark <- MaybeT . getBy . UniqueUserHref userId =<< (MaybeT $ pure murl) - btags <- lift $ withTags (entityKey bmark) - pure (bmark, btags) - -data UpsertResult = Created | Updated - -upsertBookmark :: Key User -> Maybe (Key Bookmark) -> Bookmark -> [Text] -> DB (UpsertResult, Key Bookmark) -upsertBookmark userId mbid bm tags = do - res <- case mbid of - Just bid -> do - get bid >>= \case - Just prev_bm -> do - when (userId /= bookmarkUserId prev_bm) - (throwString "unauthorized") - replaceBookmark bid prev_bm - _ -> throwString "not found" - Nothing -> do - getBy (UniqueUserHref (bookmarkUserId bm) (bookmarkHref bm)) >>= \case - Just (Entity bid prev_bm) -> replaceBookmark bid prev_bm - _ -> (Created,) <$> insert bm - insertTags (bookmarkUserId bm) (snd res) - pure res - where - prepareReplace prev_bm = do - if (bookmarkHref bm /= bookmarkHref prev_bm) - then bm { bookmarkArchiveHref = Nothing } - else bm { bookmarkArchiveHref = bookmarkArchiveHref prev_bm } - replaceBookmark bid prev_bm = do - replace bid (prepareReplace prev_bm) - deleteTags bid - pure (Updated, bid) - deleteTags bid = - deleteWhere [BookmarkTagBookmarkId ==. bid] - insertTags userId' bid' = - for_ (zip [1 ..] tags) $ - \(i, tag) -> void $ insert $ BookmarkTag userId' tag bid' i - -updateBookmarkArchiveUrl :: Key User -> Key Bookmark -> Maybe Text -> DB () -updateBookmarkArchiveUrl userId bid marchiveUrl = do - updateWhere - [BookmarkUserId ==. userId, BookmarkId ==. bid] - [BookmarkArchiveHref CP.=. marchiveUrl] - -upsertNote :: Key User -> Maybe (Key Note) -> Note -> DB (UpsertResult, Key Note) -upsertNote userId mnid note = do - case mnid of - Just nid -> do - get nid >>= \case - Just note' -> do - when (userId /= (noteUserId note')) - (throwString "unauthorized") - replace nid note - pure (Updated, nid) - _ -> throwString "not found" - Nothing -> do - (Created,) <$> insert note - --- * FileBookmarks - -data FileBookmark = FileBookmark - { fileBookmarkHref :: !Text - , fileBookmarkDescription :: !Text - , fileBookmarkExtended :: !Text - , fileBookmarkTime :: !UTCTime - , fileBookmarkShared :: !Bool - , fileBookmarkToRead :: !Bool - , fileBookmarkSelected :: !(Maybe Bool) - , fileBookmarkArchiveHref :: !(Maybe Text) - , fileBookmarkTags :: !Text - } deriving (Show, Eq, Typeable, Ord) - -instance FromJSON FileBookmark where - parseJSON (Object o) = - FileBookmark <$> o .: "href" <*> o .: "description" <*> o .: "extended" <*> - o .: "time" <*> - (boolFromYesNo <$> o .: "shared") <*> - (boolFromYesNo <$> o .: "toread") <*> - (o A..:? "selected") <*> - (o A..:? "archive_url") <*> - (o .: "tags") - parseJSON _ = A.parseFail "bad parse" - -instance ToJSON FileBookmark where - toJSON (FileBookmark {..}) = - object - [ "href" .= toJSON fileBookmarkHref - , "description" .= toJSON fileBookmarkDescription - , "extended" .= toJSON fileBookmarkExtended - , "time" .= toJSON fileBookmarkTime - , "shared" .= toJSON (boolToYesNo fileBookmarkShared) - , "toread" .= toJSON (boolToYesNo fileBookmarkToRead) - , "selected" .= toJSON fileBookmarkSelected - , "archive_url" .= toJSON fileBookmarkArchiveHref - , "tags" .= toJSON fileBookmarkTags - ] - -boolFromYesNo :: Text -> Bool -boolFromYesNo "yes" = True -boolFromYesNo _ = False - -boolToYesNo :: Bool -> Text -boolToYesNo True = "yes" -boolToYesNo _ = "no" - --- * FileNotes - -data FileNote = FileNote - { fileNoteId :: !Text - , fileNoteTitle :: !Text - , fileNoteText :: !Text - , fileNoteLength :: !Int - , fileNoteCreatedAt :: !UTCTime - , fileNoteUpdatedAt :: !UTCTime - } deriving (Show, Eq, Typeable, Ord) - -instance FromJSON FileNote where - parseJSON (Object o) = - FileNote <$> o .: "id" <*> o .: "title" <*> o .: "text" <*> - o .: "length" <*> - (readFileNoteTime =<< o .: "created_at") <*> - (readFileNoteTime =<< o .: "updated_at") - parseJSON _ = A.parseFail "bad parse" - -instance ToJSON FileNote where - toJSON (FileNote {..}) = - object - [ "id" .= toJSON fileNoteId - , "title" .= toJSON fileNoteTitle - , "text" .= toJSON fileNoteText - , "length" .= toJSON fileNoteLength - , "created_at" .= toJSON (showFileNoteTime fileNoteCreatedAt) - , "updated_at" .= toJSON (showFileNoteTime fileNoteUpdatedAt) - ] - -readFileNoteTime - :: MonadFail m - => String -> m UTCTime -readFileNoteTime = parseTimeM True defaultTimeLocale "%F %T" - -showFileNoteTime :: UTCTime -> String -showFileNoteTime = formatTime defaultTimeLocale "%F %T" +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module Model where + +import qualified ClassyPrelude.Yesod as CP +import Control.Monad.Fail (MonadFail) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A (parseFail) +import qualified Data.Attoparsec.Text as P +import qualified Control.Monad.Combinators as PC +import qualified Data.List.NonEmpty as NE +import qualified Data.Time.ISO8601 as TI +import qualified Data.Time.Clock.POSIX as TI +import qualified Database.Esqueleto as E +import Database.Esqueleto.Internal.Sql as E +import qualified Data.Time as TI +import ClassyPrelude.Yesod hiding ((||.)) +import Control.Monad.Trans.Maybe +import Control.Monad.Writer (tell) +import Data.Char (isSpace) +import Data.Either (fromRight) +import Data.Foldable (foldl, foldl1, sequenceA_) +import Data.List.NonEmpty (NonEmpty(..)) +import Database.Esqueleto hiding ((==.)) +import Pretty +import System.Directory +import Types +import qualified Data.Map.Strict as MS + +import ModelCustom + +share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase| +User json + Id Int64 + name Text + passwordHash BCrypt + apiToken Text Maybe + privateDefault Bool + archiveDefault Bool + privacyLock Bool + UniqueUserName name + deriving Show Eq Typeable Ord + +Bookmark json + Id Int64 + userId UserId + slug BmSlug default="(lower(hex(randomblob(6))))" + href Text + description Text + extended Text + time UTCTime + shared Bool + toRead Bool + selected Bool + archiveHref Text Maybe + UniqueUserHref userId href + UniqueUserSlug userId slug + deriving Show Eq Typeable Ord + +BookmarkTag json + Id Int64 + userId UserId + tag Text + bookmarkId BookmarkId + seq Int + UniqueUserTagBookmarkId userId tag bookmarkId + UniqueUserBookmarkIdTagSeq userId bookmarkId tag seq + deriving Show Eq Typeable Ord + +Note json + Id Int64 + userId UserId + slug NtSlug default="(lower(hex(randomblob(10))))" + length Int + title Text + text Text + isMarkdown Bool + shared Bool default=False + created UTCTime + updated UTCTime + deriving Show Eq Typeable Ord +|] + +newtype UTCTimeStr = + UTCTimeStr { unUTCTimeStr :: UTCTime } + deriving (Eq, Show, Read, Generic, FromJSON, ToJSON) + +instance PathPiece UTCTimeStr where + toPathPiece (UTCTimeStr u) = pack (TI.formatISO8601Millis u) + fromPathPiece s = UTCTimeStr <$> TI.parseISO8601 (unpack s) + +newtype UserNameP = + UserNameP { unUserNameP :: Text } + deriving (Eq, Show, Read) + +newtype TagsP = + TagsP { unTagsP :: [Text] } + deriving (Eq, Show, Read) + +data SharedP + = SharedAll + | SharedPublic + | SharedPrivate + deriving (Eq, Show, Read) + +data FilterP + = FilterAll + | FilterUnread + | FilterUntagged + | FilterStarred + | FilterSingle BmSlug + deriving (Eq, Show, Read) + +newtype UnreadOnly = + UnreadOnly { unUnreadOnly :: Bool } + + deriving (Eq, Show, Read) + +type Limit = Int64 +type Page = Int64 + +migrateAll :: Migration +migrateAll = migrateSchema >> migrateIndexes + +dumpMigration :: DB () +dumpMigration = printMigration migrateAll + +runMigrations :: DB () +runMigrations = runMigration migrateAll + +toMigration :: [Text] -> Migration +toMigration = lift . tell . fmap (False ,) + +migrateIndexes :: Migration +migrateIndexes = + toMigration + [ "CREATE INDEX IF NOT EXISTS idx_bookmark_time ON bookmark (user_id, time DESC)" + , "CREATE INDEX IF NOT EXISTS idx_bookmark_tag_bookmark_id ON bookmark_tag (bookmark_id, id, tag, seq)" + , "CREATE INDEX IF NOT EXISTS idx_note_user_created ON note (user_id, created DESC)" + ] + +sqlite_group_concat :: + PersistField a + => SqlExpr (E.Value a) + -> SqlExpr (E.Value a) + -> SqlExpr (E.Value Text) +sqlite_group_concat expr sep = E.unsafeSqlFunction "GROUP_CONCAT" [expr, sep] + +authenticatePassword :: Text -> Text -> DB (Maybe (Entity User)) +authenticatePassword username password = do + muser <- getBy (UniqueUserName username) + case muser of + Nothing -> return Nothing + Just dbuser -> + if validatePasswordHash (userPasswordHash (entityVal dbuser)) password + then return (Just dbuser) + else return Nothing + +getUserByName :: UserNameP -> DB (Maybe (Entity User)) +getUserByName (UserNameP uname) = do + selectFirst [UserName ==. uname] [] + +bookmarksQuery + :: Key User + -> SharedP + -> FilterP + -> [Tag] + -> Maybe Text + -> Limit + -> Page + -> DB (Int, [Entity Bookmark]) +bookmarksQuery userId sharedp filterp tags mquery limit' page = + (,) -- total count + <$> fmap (sum . fmap E.unValue) + (select $ + from \b -> do + _whereClause b + pure E.countRows) + -- paged data + <*> (select $ + from \b -> do + _whereClause b + orderBy [desc (b ^. BookmarkTime)] + limit limit' + offset ((page - 1) * limit') + pure b) + where + _whereClause b = do + where_ $ + foldl (\expr tag -> + expr &&. (exists $ -- each tag becomes an exists constraint + from \t -> + where_ (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId &&. + (t ^. BookmarkTagTag `E.like` val tag)))) + (b ^. BookmarkUserId E.==. val userId) + tags + case sharedp of + SharedAll -> pure () + SharedPublic -> where_ (b ^. BookmarkShared E.==. val True) + SharedPrivate -> where_ (b ^. BookmarkShared E.==. val False) + case filterp of + FilterAll -> pure () + FilterUnread -> where_ (b ^. BookmarkToRead E.==. val True) + FilterStarred -> where_ (b ^. BookmarkSelected E.==. val True) + FilterSingle slug -> where_ (b ^. BookmarkSlug E.==. val slug) + FilterUntagged -> where_ $ notExists $ from (\t -> where_ $ + (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId)) + -- search + sequenceA_ (parseSearchQuery (toLikeExpr b) =<< mquery) + + toLikeExpr :: E.SqlExpr (Entity Bookmark) -> Text -> E.SqlExpr (E.Value Bool) + toLikeExpr b term = fromRight p_allFields (P.parseOnly p_onefield term) + where + wild s = (E.%) ++. val s ++. (E.%) + toLikeB field s = b ^. field `E.like` wild s + p_allFields = + (toLikeB BookmarkHref term) ||. + (toLikeB BookmarkDescription term) ||. + (toLikeB BookmarkExtended term) ||. + (exists $ from (\t -> where_ $ + (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId) &&. + (t ^. BookmarkTagTag `E.like` (wild term)))) + p_onefield = p_url <|> p_title <|> p_description <|> p_tags <|> p_after <|> p_before + where + p_url = "url:" *> fmap (toLikeB BookmarkHref) P.takeText + p_title = "title:" *> fmap (toLikeB BookmarkDescription) P.takeText + p_description = "description:" *> fmap (toLikeB BookmarkExtended) P.takeText + p_tags = "tags:" *> fmap (\term' -> exists $ from (\t -> where_ $ + (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId) &&. + (t ^. BookmarkTagTag `E.like` wild term'))) P.takeText + p_after = "after:" *> fmap ((b ^. BookmarkTime E.>=.) . val) (parseTimeText =<< P.takeText) + p_before = "before:" *> fmap ((b ^. BookmarkTime E.<=.) . val) (parseTimeText =<< P.takeText) + +parseSearchQuery :: + (Text -> E.SqlExpr (E.Value Bool)) + -> Text + -> Maybe (E.SqlQuery ()) +parseSearchQuery toExpr = + fmap where_ . either (const Nothing) Just . P.parseOnly andE + where + andE = foldl1 (&&.) <$> P.many1 (P.skipSpace *> orE <|> tokenTermE) + orE = foldl1 (||.) <$> tokenTermE `P.sepBy1` P.char '|' + tokenTermE = negE termE <|> termE + where + negE p = not_ <$> (P.char '-' *> p) + termE = toExpr <$> (fieldTerm <|> quotedTerm <|> simpleTerm) + fieldTerm = concat <$> sequence [simpleTerm, P.string ":", quotedTerm <|> simpleTerm] + quotedTerm = PC.between (P.char '"') (P.char '"') (P.takeWhile1 (/= '"')) + simpleTerm = P.takeWhile1 (\c -> not (isSpace c) && c /= ':' && c /= '|') + +parseTimeText :: (TI.ParseTime t, MonadFail m, Alternative m) => Text -> m t +parseTimeText t = + asum $ + flip (parseTimeM True defaultTimeLocale) (unpack t) <$> + [ "%-m/%-d/%Y" , "%-m/%-d/%Y%z" , "%-m/%-d/%Y%Z" -- 12/31/2018 + , "%Y-%-m-%-d" , "%Y-%-m-%-d%z" , "%Y-%-m-%-d%Z" -- 2018-12-31 + , "%Y-%-m-%-dT%T" , "%Y-%-m-%-dT%T%z" , "%Y-%-m-%-dT%T%Z" -- 2018-12-31T06:40:53 + , "%s" -- 1535932800 + ] + +tagsQuery :: [Entity Bookmark] -> DB [Entity BookmarkTag] +tagsQuery bmarks = + select $ + from \t -> do + where_ (t ^. BookmarkTagBookmarkId `in_` valList (fmap entityKey bmarks)) + orderBy [asc (t ^. BookmarkTagSeq)] + pure t + +withTags :: Key Bookmark -> DB [Entity BookmarkTag] +withTags key = selectList [BookmarkTagBookmarkId ==. key] [Asc BookmarkTagSeq] + +-- Note List Query + + +getNote :: Key User -> NtSlug -> DB (Maybe (Entity Note)) +getNote userKey slug = + selectFirst [NoteUserId ==. userKey, NoteSlug ==. slug] [] + +getNoteList :: Key User -> Maybe Text -> SharedP -> Limit -> Page -> DB (Int, [Entity Note]) +getNoteList key mquery sharedp limit' page = + (,) -- total count + <$> fmap (sum . fmap E.unValue) + (select $ + from \b -> do + _whereClause b + pure $ E.countRows) + <*> (select $ + from \b -> do + _whereClause b + orderBy [desc (b ^. NoteCreated)] + limit limit' + offset ((page - 1) * limit') + pure b) + where + _whereClause b = do + where_ $ (b ^. NoteUserId E.==. val key) + -- search + sequenceA_ (parseSearchQuery (toLikeExpr b) =<< mquery) + case sharedp of + SharedAll -> pure () + SharedPublic -> where_ (b ^. NoteShared E.==. val True) + SharedPrivate -> where_ (b ^. NoteShared E.==. val False) + + toLikeExpr :: E.SqlExpr (Entity Note) -> Text -> E.SqlExpr (E.Value Bool) + toLikeExpr b term = fromRight p_allFields (P.parseOnly p_onefield term) + where + wild s = (E.%) ++. val s ++. (E.%) + toLikeN field s = b ^. field `E.like` wild s + p_allFields = toLikeN NoteTitle term ||. toLikeN NoteText term + p_onefield = p_title <|> p_text <|> p_after <|> p_before + where + p_title = "title:" *> fmap (toLikeN NoteTitle) P.takeText + p_text = "description:" *> fmap (toLikeN NoteText) P.takeText + p_after = "after:" *> fmap ((b ^. NoteCreated E.>=.) . val) (parseTimeText =<< P.takeText) + p_before = "before:" *> fmap ((b ^. NoteCreated E.<=.) . val) (parseTimeText =<< P.takeText) + +-- Bookmark Files + +mkBookmarkTags :: Key User -> Key Bookmark -> [Tag] -> [BookmarkTag] +mkBookmarkTags userId bookmarkId tags = + (\(i, tag) -> BookmarkTag userId tag bookmarkId i) <$> zip [1 ..] tags + + +fileBookmarkToBookmark :: UserId -> FileBookmark -> IO Bookmark +fileBookmarkToBookmark user (FileBookmark {..}) = do + slug <- mkBmSlug + pure $ + Bookmark + { bookmarkUserId = user + , bookmarkSlug = slug + , bookmarkHref = fileBookmarkHref + , bookmarkDescription = fileBookmarkDescription + , bookmarkExtended = fileBookmarkExtended + , bookmarkTime = fileBookmarkTime + , bookmarkShared = fileBookmarkShared + , bookmarkToRead = fileBookmarkToRead + , bookmarkSelected = (fromMaybe False fileBookmarkSelected) + , bookmarkArchiveHref = fileBookmarkArchiveHref + } + +bookmarkTofileBookmark :: Bookmark -> Text -> FileBookmark +bookmarkTofileBookmark (Bookmark {..}) tags = + FileBookmark + { fileBookmarkHref = bookmarkHref + , fileBookmarkDescription = bookmarkDescription + , fileBookmarkExtended = bookmarkExtended + , fileBookmarkTime = bookmarkTime + , fileBookmarkShared = bookmarkShared + , fileBookmarkToRead = bookmarkToRead + , fileBookmarkSelected = Just bookmarkSelected + , fileBookmarkArchiveHref = bookmarkArchiveHref + , fileBookmarkTags = tags + } + +data FFBookmarkNode = FFBookmarkNode + { firefoxBookmarkChildren :: Maybe [FFBookmarkNode] + , firefoxBookmarkDateAdded :: !TI.POSIXTime + , firefoxBookmarkGuid :: !Text + , firefoxBookmarkIconUri :: !(Maybe Text) + , firefoxBookmarkId :: !Int + , firefoxBookmarkIndex :: !Int + , firefoxBookmarkLastModified :: !TI.POSIXTime + , firefoxBookmarkRoot :: !(Maybe Text) + , firefoxBookmarkTitle :: !Text + , firefoxBookmarkType :: !Text + , firefoxBookmarkTypeCode :: !Int + , firefoxBookmarkUri :: !(Maybe Text) + } deriving (Show, Eq, Typeable, Ord) + +instance FromJSON FFBookmarkNode where + parseJSON (Object o) = + FFBookmarkNode <$> + (o A..:? "children") <*> + (o .: "dateAdded") <*> + o .: "guid" <*> + (o A..:? "iconUri") <*> + o .: "id" <*> + o .: "index" <*> + (o .: "lastModified") <*> + (o A..:? "root") <*> + (o .: "title") <*> + (o .: "type") <*> + (o .: "typeCode") <*> + (o A..:? "uri") + parseJSON _ = A.parseFail "bad parse" + +firefoxBookmarkNodeToBookmark :: UserId -> FFBookmarkNode -> IO [Bookmark] +firefoxBookmarkNodeToBookmark user (FFBookmarkNode {..}) = do + case firefoxBookmarkTypeCode of + 1 -> do + slug <- mkBmSlug + pure $ + [ Bookmark + { bookmarkUserId = user + , bookmarkSlug = slug + , bookmarkHref = (fromMaybe "" firefoxBookmarkUri) + , bookmarkDescription = firefoxBookmarkTitle + , bookmarkExtended = "" + , bookmarkTime = (TI.posixSecondsToUTCTime (firefoxBookmarkDateAdded / 1000000)) + , bookmarkShared = True + , bookmarkToRead = False + , bookmarkSelected = False + , bookmarkArchiveHref = Nothing + } + ] + 2 -> + join <$> + mapM + (firefoxBookmarkNodeToBookmark user) + (fromMaybe [] firefoxBookmarkChildren) + _ -> pure [] + + +insertFileBookmarks :: Key User -> FilePath -> DB (Either String Int) +insertFileBookmarks userId bookmarkFile = do + mfmarks <- liftIO $ readFileBookmarks bookmarkFile + case mfmarks of + Left e -> pure $ Left e + Right fmarks -> do + bmarks <- liftIO $ mapM (fileBookmarkToBookmark userId) fmarks + mbids <- mapM insertUnique bmarks + void $ + mapM insertUnique $ + concatMap (uncurry (mkBookmarkTags userId)) $ + catMaybes $ + zipWith + (\mbid tags -> ((, tags) <$> mbid)) + mbids + (extractTags <$> fmarks) + pure $ Right (length bmarks) + + where + extractTags = words . fileBookmarkTags + +insertFFBookmarks :: Key User -> FilePath -> DB (Either String Int) +insertFFBookmarks userId bookmarkFile = do + mfmarks <- liftIO $ readFFBookmarks bookmarkFile + case mfmarks of + Left e -> pure $ Left e + Right fmarks -> do + bmarks <- liftIO $ firefoxBookmarkNodeToBookmark userId fmarks + _ <- mapM insertUnique bmarks + pure $ Right (length bmarks) + + +readFileBookmarks :: MonadIO m => FilePath -> m (Either String [FileBookmark]) +readFileBookmarks fpath = + pure . A.eitherDecode' . fromStrict =<< readFile fpath + +readFFBookmarks :: MonadIO m => FilePath -> m (Either String FFBookmarkNode) +readFFBookmarks fpath = + pure . A.eitherDecode' . fromStrict =<< readFile fpath + +exportFileBookmarks :: Key User -> FilePath -> DB () +exportFileBookmarks user fpath = do + liftIO . A.encodeFile fpath =<< getFileBookmarks user + +getFileBookmarks :: Key User -> DB [FileBookmark] +getFileBookmarks user = do + marks <- allUserBookmarks user + pure $ fmap (\(bm, t) -> bookmarkTofileBookmark (entityVal bm) t) marks + +-- returns a list of pair of bookmark with tags merged into a string +allUserBookmarks :: Key User -> DB [(Entity Bookmark, Text)] +allUserBookmarks user = do + bmarks <- bquery + tags <- tquery + let tagmap = MS.fromList tags + pure $ (\bm@(Entity bid _) -> (bm, findWithDefault mempty bid tagmap)) <$> bmarks + where + bquery :: DB [Entity Bookmark] + bquery = + select $ + from \b -> do + where_ (b ^. BookmarkUserId E.==. val user) + orderBy [asc (b ^. BookmarkTime)] + pure b + tquery :: DB [(Key Bookmark, Text)] + tquery = + fmap (\(tid, tags) -> (E.unValue tid, E.unValue tags)) <$> + (select $ + from \t -> do + where_ (t ^. BookmarkTagUserId E.==. val user) + E.groupBy (t ^. BookmarkTagBookmarkId) + let tags = sqlite_group_concat (t ^. BookmarkTagTag) (E.val " ") + pure (t ^. BookmarkTagBookmarkId, tags)) + + +data TagCloudMode + = TagCloudModeTop Bool Int -- { mode: "top", value: 200 } + | TagCloudModeLowerBound Bool Int -- { mode: "lowerBound", value: 20 } + | TagCloudModeRelated Bool [Tag] + | TagCloudModeNone + deriving (Show, Eq, Read, Generic) + +isExpanded :: TagCloudMode -> Bool +isExpanded (TagCloudModeTop e _) = e +isExpanded (TagCloudModeLowerBound e _) = e +isExpanded (TagCloudModeRelated e _) = e +isExpanded TagCloudModeNone = False + +instance FromJSON TagCloudMode where + parseJSON (Object o) = + case lookup "mode" o of + Just (String "top") -> TagCloudModeTop <$> o .: "expanded" <*> o .: "value" + Just (String "lowerBound") -> TagCloudModeLowerBound <$> o .: "expanded" <*> o .: "value" + Just (String "related") -> TagCloudModeRelated <$> o .: "expanded" <*> (fmap words (o .: "value")) + Just (String "none") -> pure TagCloudModeNone + _ -> A.parseFail "bad parse" + parseJSON _ = A.parseFail "bad parse" + +instance ToJSON TagCloudMode where + toJSON (TagCloudModeTop e i) = + object [ "mode" .= String "top" + , "value" .= toJSON i + , "expanded" .= Bool e + ] + toJSON (TagCloudModeLowerBound e i) = + object [ "mode" .= String "lowerBound" + , "value" .= toJSON i + , "expanded" .= Bool e + ] + toJSON (TagCloudModeRelated e tags) = + object [ "mode" .= String "related" + , "value" .= String (unwords tags) + , "expanded" .= Bool e + ] + toJSON TagCloudModeNone = + object [ "mode" .= String "none" + , "value" .= Null + , "expanded" .= Bool False + ] + + +type Tag = Text + +tagCountTop :: Key User -> Int -> DB [(Text, Int)] +tagCountTop user top = + sortOn (toLower . fst) . + fmap (\(tname, tcount) -> (E.unValue tname, E.unValue tcount)) <$> + ( select $ + from \t -> do + where_ (t ^. BookmarkTagUserId E.==. val user) + E.groupBy (E.lower_ $ t ^. BookmarkTagTag) + let countRows' = E.countRows + E.orderBy [E.desc countRows'] + E.limit ((fromIntegral . toInteger) top) + pure $ (t ^. BookmarkTagTag, countRows') + ) + +tagCountLowerBound :: Key User -> Int -> DB [(Text, Int)] +tagCountLowerBound user lowerBound = + fmap (\(tname, tcount) -> (E.unValue tname, E.unValue tcount)) <$> + ( select $ + from \t -> do + where_ (t ^. BookmarkTagUserId E.==. val user) + E.groupBy (E.lower_ $ t ^. BookmarkTagTag) + let countRows' = E.countRows + E.orderBy [E.asc (t ^. BookmarkTagTag)] + E.having (countRows' E.>=. E.val lowerBound) + pure $ (t ^. BookmarkTagTag, countRows') + ) + +tagCountRelated :: Key User -> [Tag] -> DB [(Text, Int)] +tagCountRelated user tags = + fmap (\(tname, tcount) -> (E.unValue tname, E.unValue tcount)) <$> + ( select $ + from \t -> do + where_ $ + foldl (\expr tag -> + expr &&. (exists $ + from \u -> + where_ (u ^. BookmarkTagBookmarkId E.==. t ^. BookmarkTagBookmarkId &&. + (u ^. BookmarkTagTag `E.like` val tag)))) + (t ^. BookmarkTagUserId E.==. val user) + tags + E.groupBy (E.lower_ $ t ^. BookmarkTagTag) + let countRows' = E.countRows + E.orderBy [E.asc $ E.lower_ $ (t ^. BookmarkTagTag)] + pure $ (t ^. BookmarkTagTag, countRows') + ) + +-- Notes + +fileNoteToNote :: UserId -> FileNote -> IO Note +fileNoteToNote user (FileNote {..} ) = do + slug <- mkNtSlug + pure $ + Note + { noteUserId = user + , noteSlug = slug + , noteLength = fileNoteLength + , noteTitle = fileNoteTitle + , noteText = fileNoteText + , noteIsMarkdown = False + , noteShared = False + , noteCreated = fileNoteCreatedAt + , noteUpdated = fileNoteUpdatedAt + } + +insertDirFileNotes :: Key User -> FilePath -> DB (Either String Int) +insertDirFileNotes userId noteDirectory = do + mfnotes <- liftIO $ readFileNotes noteDirectory + case mfnotes of + Left e -> pure $ Left e + Right fnotes -> do + notes <- liftIO $ mapM (fileNoteToNote userId) fnotes + void $ mapM insertUnique notes + pure $ Right (length notes) + where + readFileNotes :: MonadIO m => FilePath -> m (Either String [FileNote]) + readFileNotes fdir = do + files <- liftIO (listDirectory fdir) + noteBSS <- mapM (readFile . (fdir )) files + pure (mapM (A.eitherDecode' . fromStrict) noteBSS) + +-- AccountSettingsForm +data AccountSettingsForm = AccountSettingsForm + { _privateDefault :: Bool + , _archiveDefault :: Bool + , _privacyLock :: Bool + } deriving (Show, Eq, Read, Generic) + +instance FromJSON AccountSettingsForm where parseJSON = A.genericParseJSON gDefaultFormOptions +instance ToJSON AccountSettingsForm where toJSON = A.genericToJSON gDefaultFormOptions + +toAccountSettingsForm :: User -> AccountSettingsForm +toAccountSettingsForm (User {..}) = + AccountSettingsForm + { _privateDefault = userPrivateDefault + , _archiveDefault = userArchiveDefault + , _privacyLock = userPrivacyLock + } + +updateUserFromAccountSettingsForm :: Key User -> AccountSettingsForm -> DB () +updateUserFromAccountSettingsForm userId (AccountSettingsForm {..}) = do + CP.update userId + [ UserPrivateDefault CP.=. _privateDefault + , UserArchiveDefault CP.=. _archiveDefault + , UserPrivacyLock CP.=. _privacyLock + ] + +-- BookmarkForm + +data BookmarkForm = BookmarkForm + { _url :: Text + , _title :: Maybe Text + , _description :: Maybe Textarea + , _tags :: Maybe Text + , _private :: Maybe Bool + , _toread :: Maybe Bool + , _bid :: Maybe Int64 + , _slug :: Maybe BmSlug + , _selected :: Maybe Bool + , _time :: Maybe UTCTimeStr + , _archiveUrl :: Maybe Text + } deriving (Show, Eq, Read, Generic) + +instance FromJSON BookmarkForm where parseJSON = A.genericParseJSON gDefaultFormOptions +instance ToJSON BookmarkForm where toJSON = A.genericToJSON gDefaultFormOptions + +gDefaultFormOptions :: A.Options +gDefaultFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 } + +toBookmarkFormList :: [Entity Bookmark] -> [Entity BookmarkTag] -> [BookmarkForm] +toBookmarkFormList bs as = do + b <- bs + let bid = E.entityKey b + let btags = filter ((==) bid . bookmarkTagBookmarkId . E.entityVal) as + pure $ _toBookmarkForm (b, btags) + +_toBookmarkForm :: (Entity Bookmark, [Entity BookmarkTag]) -> BookmarkForm +_toBookmarkForm (Entity bid Bookmark {..}, tags) = + BookmarkForm + { _url = bookmarkHref + , _title = Just bookmarkDescription + , _description = Just $ Textarea $ bookmarkExtended + , _tags = Just $ unwords $ fmap (bookmarkTagTag . entityVal) tags + , _private = Just $ not bookmarkShared + , _toread = Just $ bookmarkToRead + , _bid = Just $ unBookmarkKey $ bid + , _slug = Just $ bookmarkSlug + , _selected = Just $ bookmarkSelected + , _time = Just $ UTCTimeStr $ bookmarkTime + , _archiveUrl = bookmarkArchiveHref + } + +_toBookmark :: UserId -> BookmarkForm -> IO Bookmark +_toBookmark userId BookmarkForm {..} = do + time <- liftIO getCurrentTime + slug <- maybe mkBmSlug pure _slug + pure $ + Bookmark + { bookmarkUserId = userId + , bookmarkSlug = slug + , bookmarkHref = _url + , bookmarkDescription = fromMaybe "" _title + , bookmarkExtended = maybe "" unTextarea _description + , bookmarkTime = fromMaybe time (fmap unUTCTimeStr _time) + , bookmarkShared = maybe True not _private + , bookmarkToRead = fromMaybe False _toread + , bookmarkSelected = fromMaybe False _selected + , bookmarkArchiveHref = _archiveUrl + } + +fetchBookmarkByUrl :: Key User -> Maybe Text -> DB (Maybe (Entity Bookmark, [Entity BookmarkTag])) +fetchBookmarkByUrl userId murl = runMaybeT do + bmark <- MaybeT . getBy . UniqueUserHref userId =<< (MaybeT $ pure murl) + btags <- lift $ withTags (entityKey bmark) + pure (bmark, btags) + +data UpsertResult = Created | Updated + +upsertBookmark :: Key User -> Maybe (Key Bookmark) -> Bookmark -> [Text] -> DB (UpsertResult, Key Bookmark) +upsertBookmark userId mbid bm tags = do + res <- case mbid of + Just bid -> do + get bid >>= \case + Just prev_bm -> do + when (userId /= bookmarkUserId prev_bm) + (throwString "unauthorized") + replaceBookmark bid prev_bm + _ -> throwString "not found" + Nothing -> do + getBy (UniqueUserHref (bookmarkUserId bm) (bookmarkHref bm)) >>= \case + Just (Entity bid prev_bm) -> replaceBookmark bid prev_bm + _ -> (Created,) <$> insert bm + insertTags (bookmarkUserId bm) (snd res) + pure res + where + prepareReplace prev_bm = do + if (bookmarkHref bm /= bookmarkHref prev_bm) + then bm { bookmarkArchiveHref = Nothing } + else bm { bookmarkArchiveHref = bookmarkArchiveHref prev_bm } + replaceBookmark bid prev_bm = do + replace bid (prepareReplace prev_bm) + deleteTags bid + pure (Updated, bid) + deleteTags bid = + deleteWhere [BookmarkTagBookmarkId ==. bid] + insertTags userId' bid' = + for_ (zip [1 ..] tags) $ + \(i, tag) -> void $ insert $ BookmarkTag userId' tag bid' i + +updateBookmarkArchiveUrl :: Key User -> Key Bookmark -> Maybe Text -> DB () +updateBookmarkArchiveUrl userId bid marchiveUrl = do + updateWhere + [BookmarkUserId ==. userId, BookmarkId ==. bid] + [BookmarkArchiveHref CP.=. marchiveUrl] + +upsertNote :: Key User -> Maybe (Key Note) -> Note -> DB (UpsertResult, Key Note) +upsertNote userId mnid note = do + case mnid of + Just nid -> do + get nid >>= \case + Just note' -> do + when (userId /= (noteUserId note')) + (throwString "unauthorized") + replace nid note + pure (Updated, nid) + _ -> throwString "not found" + Nothing -> do + (Created,) <$> insert note + +-- * FileBookmarks + +data FileBookmark = FileBookmark + { fileBookmarkHref :: !Text + , fileBookmarkDescription :: !Text + , fileBookmarkExtended :: !Text + , fileBookmarkTime :: !UTCTime + , fileBookmarkShared :: !Bool + , fileBookmarkToRead :: !Bool + , fileBookmarkSelected :: !(Maybe Bool) + , fileBookmarkArchiveHref :: !(Maybe Text) + , fileBookmarkTags :: !Text + } deriving (Show, Eq, Typeable, Ord) + +instance FromJSON FileBookmark where + parseJSON (Object o) = + FileBookmark <$> o .: "href" <*> o .: "description" <*> o .: "extended" <*> + o .: "time" <*> + (boolFromYesNo <$> o .: "shared") <*> + (boolFromYesNo <$> o .: "toread") <*> + (o A..:? "selected") <*> + (o A..:? "archive_url") <*> + (o .: "tags") + parseJSON _ = A.parseFail "bad parse" + +instance ToJSON FileBookmark where + toJSON (FileBookmark {..}) = + object + [ "href" .= toJSON fileBookmarkHref + , "description" .= toJSON fileBookmarkDescription + , "extended" .= toJSON fileBookmarkExtended + , "time" .= toJSON fileBookmarkTime + , "shared" .= toJSON (boolToYesNo fileBookmarkShared) + , "toread" .= toJSON (boolToYesNo fileBookmarkToRead) + , "selected" .= toJSON fileBookmarkSelected + , "archive_url" .= toJSON fileBookmarkArchiveHref + , "tags" .= toJSON fileBookmarkTags + ] + +boolFromYesNo :: Text -> Bool +boolFromYesNo "yes" = True +boolFromYesNo _ = False + +boolToYesNo :: Bool -> Text +boolToYesNo True = "yes" +boolToYesNo _ = "no" + +-- * FileNotes + +data FileNote = FileNote + { fileNoteId :: !Text + , fileNoteTitle :: !Text + , fileNoteText :: !Text + , fileNoteLength :: !Int + , fileNoteCreatedAt :: !UTCTime + , fileNoteUpdatedAt :: !UTCTime + } deriving (Show, Eq, Typeable, Ord) + +instance FromJSON FileNote where + parseJSON (Object o) = + FileNote <$> o .: "id" <*> o .: "title" <*> o .: "text" <*> + o .: "length" <*> + (readFileNoteTime =<< o .: "created_at") <*> + (readFileNoteTime =<< o .: "updated_at") + parseJSON _ = A.parseFail "bad parse" + +instance ToJSON FileNote where + toJSON (FileNote {..}) = + object + [ "id" .= toJSON fileNoteId + , "title" .= toJSON fileNoteTitle + , "text" .= toJSON fileNoteText + , "length" .= toJSON fileNoteLength + , "created_at" .= toJSON (showFileNoteTime fileNoteCreatedAt) + , "updated_at" .= toJSON (showFileNoteTime fileNoteUpdatedAt) + ] + +readFileNoteTime + :: MonadFail m + => String -> m UTCTime +readFileNoteTime = parseTimeM True defaultTimeLocale "%F %T" + +showFileNoteTime :: UTCTime -> String +showFileNoteTime = formatTime defaultTimeLocale "%F %T" diff --git a/src/PathPiece.hs b/src/PathPiece.hs index e3b258b..68a6d14 100644 --- a/src/PathPiece.hs +++ b/src/PathPiece.hs @@ -1,55 +1,55 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module PathPiece where - -import Data.Text (splitOn) - -import Import.NoFoundation - --- PathPiece - -instance PathPiece UserNameP where - toPathPiece (UserNameP i) = "u:" <> i - fromPathPiece s = - case splitOn ":" s of - ["u", ""] -> Nothing - ["u", uname] -> Just $ UserNameP uname - _ -> Nothing - -instance PathPiece TagsP where - toPathPiece (TagsP tags) = "t:" <> (intercalate "+" tags) - fromPathPiece s = - case splitOn ":" s of - ["t", ""] -> Nothing - ["t", tags] -> Just $ TagsP (splitOn "+" tags) - _ -> Nothing - -instance PathPiece SharedP where - toPathPiece = \case - SharedAll -> "" - SharedPublic -> "public" - SharedPrivate -> "private" - fromPathPiece = \case - "public" -> Just SharedPublic - "private" -> Just SharedPrivate - _ -> Nothing - -instance PathPiece FilterP where - toPathPiece = \case - FilterAll -> "" - FilterUnread -> "unread" - FilterUntagged -> "untagged" - FilterStarred -> "starred" - FilterSingle slug -> "b:" <> unBmSlug slug - fromPathPiece = \case - "unread" -> Just FilterUnread - "untagged" -> Just FilterUntagged - "starred" -> Just FilterStarred - s -> case splitOn ":" s of - ["b", ""] -> Nothing - ["b", slug] -> Just $ FilterSingle (BmSlug slug) - _ -> Nothing - - -deriving instance PathPiece NtSlug -deriving instance PathPiece BmSlug +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module PathPiece where + +import Data.Text (splitOn) + +import Import.NoFoundation + +-- PathPiece + +instance PathPiece UserNameP where + toPathPiece (UserNameP i) = "u:" <> i + fromPathPiece s = + case splitOn ":" s of + ["u", ""] -> Nothing + ["u", uname] -> Just $ UserNameP uname + _ -> Nothing + +instance PathPiece TagsP where + toPathPiece (TagsP tags) = "t:" <> (intercalate "+" tags) + fromPathPiece s = + case splitOn ":" s of + ["t", ""] -> Nothing + ["t", tags] -> Just $ TagsP (splitOn "+" tags) + _ -> Nothing + +instance PathPiece SharedP where + toPathPiece = \case + SharedAll -> "" + SharedPublic -> "public" + SharedPrivate -> "private" + fromPathPiece = \case + "public" -> Just SharedPublic + "private" -> Just SharedPrivate + _ -> Nothing + +instance PathPiece FilterP where + toPathPiece = \case + FilterAll -> "" + FilterUnread -> "unread" + FilterUntagged -> "untagged" + FilterStarred -> "starred" + FilterSingle slug -> "b:" <> unBmSlug slug + fromPathPiece = \case + "unread" -> Just FilterUnread + "untagged" -> Just FilterUntagged + "starred" -> Just FilterStarred + s -> case splitOn ":" s of + ["b", ""] -> Nothing + ["b", slug] -> Just $ FilterSingle (BmSlug slug) + _ -> Nothing + + +deriving instance PathPiece NtSlug +deriving instance PathPiece BmSlug diff --git a/static/css/main.css b/static/css/main.css index b443550..dce5f29 100644 --- a/static/css/main.css +++ b/static/css/main.css @@ -1,205 +1,205 @@ -html { - height: 102%; -} - -body { - height: 102%; - word-wrap: break-word; -} - -button { - background:none; - border:none; - padding:0; - cursor:pointer; -} - -button:focus { - outline: none; -} - - -[hidden] { - display: none !important -} -input::placeholder { - color: lightgray -} -.queryInput { - width: 128px; - padding: 0 22px 0 2px; - border-radius: 3px; - border-style: solid; - border-width: 1px; - border-color: gray; - height: 22px; - line-height: 22px; - transition: width .1s ease-in-out -} -.queryInput.search-inactive {} -.queryInput:focus { - width: 175px; -} -.submitting .queryInput, -.queryInput.search-active { - border-color: #990; - border-width: 2px; - background-color: #FF9; - width: 175px; -} -.queryIcon { - position: absolute; - right: 0; - top:1px; - cursor:pointer; - width:20px; - height: 20px; - fill: currentColor; -} -label { - cursor: pointer; -} -.close-x-wrap { - float: left; - width: 17px; - height: 17px; - top: 2px; - position: relative; - right: 2px; -} -.close-x { - stroke: gray; - fill: transparent; - stroke-linecap: round; - stroke-width: 3; -} -.query-info-icon { - position: absolute; - top: 0px; - right: -18px; - text-decoration: none; - font-size: 12px; - padding: 0 8px 8px 0; -} -.star { - margin-left:-20px; - font-size:1.2em; - position:relative; - top:-2px; -} - -.star button { - transition: color .1s; -} -.star.selected button { - color:#22a; -} -.edit_links button { - transition: color .1s ease-in; -} - -.tag { - color:#a51; - line-height:190%; - display: inline-block; -} -.tag-include { - color:rgb(221, 221, 221); - line-height:190%; - display: inline-block; -} -.tag-exclude { - color:rgb(255, 170, 170); - line-height:190%; - display: inline-block; -} - -.private { background:#ddd;border:1px solid #d1d1d1; } -.unread { color:#b41 } -.mark_read {color: #a81;} -.flash { color:green;background:#efe } - -.top_menu { - margin-top:6px; -} -.top_menu a { - color: blue; -} -.bookmarklet { - padding:1px 2px 0px 2px; -} - -.alert { - background:#ced; - border:1px solid #acc; -} - -.edit_bookmark_form {color:#888;} -.edit_bookmark_form input {border:1px solid #ddd;} -.edit_bookmark_form textarea {border:1px solid #ddd;} - -.nav-active { - background:#ff8; - color:blue; -} - -/* mobile device */ -@media only screen and (max-width : 750px) { - body { - -webkit-text-size-adjust: none; - } - .display { - float: none - } -} - -@media only screen and (max-width : 500px) { - .filters { - clear: both; - position: relative; - top: 2px; - } -} - -.rdim { - opacity: .8; - transition: all .15s ease-in; -} -.rdim:hover, -.rdim:focus { - opacity: 1; - transition: all .15s ease-in; -} -.display .description > div p, -.display .description > div pre -{ - margin-top: 9px; - margin-bottom: 9px; -} -.display .description > div > *:first-child { - margin-top: 2px; -} -.display .description > div > *:last-child { - margin-bottom: 2px; -} -.display .description > div > ol li p { - margin-top: 0; - margin-bottom: 0; -} -.display .description > div > ul li p { - margin-top: 0; - margin-bottom: 0; -} -.display .description > div ol { - padding-left: 23px; -} -.display .description > div ul { - padding-left: 23px; -} -code, pre { - font-size:13px; -} - -#content:not([view-rendered]) .view-delay { - display: none !important -} +html { + height: 102%; +} + +body { + height: 102%; + word-wrap: break-word; +} + +button { + background:none; + border:none; + padding:0; + cursor:pointer; +} + +button:focus { + outline: none; +} + + +[hidden] { + display: none !important +} +input::placeholder { + color: lightgray +} +.queryInput { + width: 128px; + padding: 0 22px 0 2px; + border-radius: 3px; + border-style: solid; + border-width: 1px; + border-color: gray; + height: 22px; + line-height: 22px; + transition: width .1s ease-in-out +} +.queryInput.search-inactive {} +.queryInput:focus { + width: 175px; +} +.submitting .queryInput, +.queryInput.search-active { + border-color: #990; + border-width: 2px; + background-color: #FF9; + width: 175px; +} +.queryIcon { + position: absolute; + right: 0; + top:1px; + cursor:pointer; + width:20px; + height: 20px; + fill: currentColor; +} +label { + cursor: pointer; +} +.close-x-wrap { + float: left; + width: 17px; + height: 17px; + top: 2px; + position: relative; + right: 2px; +} +.close-x { + stroke: gray; + fill: transparent; + stroke-linecap: round; + stroke-width: 3; +} +.query-info-icon { + position: absolute; + top: 0px; + right: -18px; + text-decoration: none; + font-size: 12px; + padding: 0 8px 8px 0; +} +.star { + margin-left:-20px; + font-size:1.2em; + position:relative; + top:-2px; +} + +.star button { + transition: color .1s; +} +.star.selected button { + color:#22a; +} +.edit_links button { + transition: color .1s ease-in; +} + +.tag { + color:#a51; + line-height:190%; + display: inline-block; +} +.tag-include { + color:rgb(221, 221, 221); + line-height:190%; + display: inline-block; +} +.tag-exclude { + color:rgb(255, 170, 170); + line-height:190%; + display: inline-block; +} + +.private { background:#ddd;border:1px solid #d1d1d1; } +.unread { color:#b41 } +.mark_read {color: #a81;} +.flash { color:green;background:#efe } + +.top_menu { + margin-top:6px; +} +.top_menu a { + color: blue; +} +.bookmarklet { + padding:1px 2px 0px 2px; +} + +.alert { + background:#ced; + border:1px solid #acc; +} + +.edit_bookmark_form {color:#888;} +.edit_bookmark_form input {border:1px solid #ddd;} +.edit_bookmark_form textarea {border:1px solid #ddd;} + +.nav-active { + background:#ff8; + color:blue; +} + +/* mobile device */ +@media only screen and (max-width : 750px) { + body { + -webkit-text-size-adjust: none; + } + .display { + float: none + } +} + +@media only screen and (max-width : 500px) { + .filters { + clear: both; + position: relative; + top: 2px; + } +} + +.rdim { + opacity: .8; + transition: all .15s ease-in; +} +.rdim:hover, +.rdim:focus { + opacity: 1; + transition: all .15s ease-in; +} +.display .description > div p, +.display .description > div pre +{ + margin-top: 9px; + margin-bottom: 9px; +} +.display .description > div > *:first-child { + margin-top: 2px; +} +.display .description > div > *:last-child { + margin-bottom: 2px; +} +.display .description > div > ol li p { + margin-top: 0; + margin-bottom: 0; +} +.display .description > div > ul li p { + margin-top: 0; + margin-bottom: 0; +} +.display .description > div ol { + padding-left: 23px; +} +.display .description > div ul { + padding-left: 23px; +} +code, pre { + font-size:13px; +} + +#content:not([view-rendered]) .view-delay { + display: none !important +} diff --git a/static/js/app.min.js.gz b/static/js/app.min.js.gz index a54cdc06d9ecd27cec05a2d69a95fd6679f4da54..cf469bb9d512a4a0b3d8c9185beed6d6c1175952 100644 GIT binary patch delta 21 ccmX^2h2`8A7Iyh=4vye}@<#Tp?2PVK0ACOXE&u=k delta 21 ccmX^2h2`8A7Iyh=4i14o!Hw)&*%{rf0AXGSa{vGU diff --git a/static/js/app.min.js.map.gz b/static/js/app.min.js.map.gz index eb58f474d6c6f889916f5c00c3dd23733fff2b52..f38ce61b36555e58b5848165146c98e1724142e8 100644 GIT binary patch delta 30 lcmez0BJjUOfL*?ugCjVgypg??ow1djsg<31D?3XC69Akq2yOrX delta 30 lcmez0BJjUOfL*?ugG1m?a3gywJ7X(5Q!6|3R(6&OCIF!72(thH diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet index 8cd09bc..b7133fe 100644 --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -1,38 +1,38 @@ -$newline never -\ -\ -\ -\ -\ - - - - - #{pageTitle pc} - <meta name="description" content="Espial is an open-source, web-based bookmarking server."> - <meta name="robots" content="noindex, nofollow, noodp, noydir"> - <meta name="viewport" content="width=device-width,initial-scale=1"> - $maybe sourceCodeUri <- msourceCodeUri - <meta name="source" content="#{ sourceCodeUri }"> - - ^{pageHead pc} - - \<!--[if lt IE 9]> - \<script src="@{StaticR js_html5shiv_min_js}"></script> - \<![endif]--> - - <script>document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/, 'js'); - <script src="@{StaticR js_js_cookie_2_2_0_min_js}"> - <script> - var app = - { csrfHeaderName: "#{ TE.decodeUtf8 $ CI.foldedCase defaultCsrfHeaderName }" - , csrfParamName: "#{ defaultCsrfParamName }" - , csrfCookieName: "#{ TE.decodeUtf8 defaultCsrfCookieName }" - , csrfToken: Cookies.get("#{ TE.decodeUtf8 defaultCsrfCookieName }") - , homeR: "@{ HomeR }" - , authRlogoutR: "@{ AuthR LogoutR }" - , userFilterRFilterSingle: "" - , dat: {bmarks : [], bmark: {}, isowner: false, notes: []} - }; - <body .f6.dark-gray.helvetica> - ^{pageBody pc} +$newline never +\<!doctype html> +\<!--[if lt IE 7]> <html class="no-js ie6 oldie" lang="en"> <![endif]--> +\<!--[if IE 7]> <html class="no-js ie7 oldie" lang="en"> <![endif]--> +\<!--[if IE 8]> <html class="no-js ie8 oldie" lang="en"> <![endif]--> +\<!--[if gt IE 8]><!--> +<html class="no-js" lang="en"> <!--<![endif]--> + <head> + <meta charset="UTF-8"> + + <title>#{pageTitle pc} + <meta name="description" content="Espial is an open-source, web-based bookmarking server."> + <meta name="robots" content="noindex, nofollow, noodp, noydir"> + <meta name="viewport" content="width=device-width,initial-scale=1"> + $maybe sourceCodeUri <- msourceCodeUri + <meta name="source" content="#{ sourceCodeUri }"> + + ^{pageHead pc} + + \<!--[if lt IE 9]> + \<script src="@{StaticR js_html5shiv_min_js}"></script> + \<![endif]--> + + <script>document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/, 'js'); + <script src="@{StaticR js_js_cookie_2_2_0_min_js}"> + <script> + var app = + { csrfHeaderName: "#{ TE.decodeUtf8 $ CI.foldedCase defaultCsrfHeaderName }" + , csrfParamName: "#{ defaultCsrfParamName }" + , csrfCookieName: "#{ TE.decodeUtf8 defaultCsrfCookieName }" + , csrfToken: Cookies.get("#{ TE.decodeUtf8 defaultCsrfCookieName }") + , homeR: "@{ HomeR }" + , authRlogoutR: "@{ AuthR LogoutR }" + , userFilterRFilterSingle: "" + , dat: {bmarks : [], bmark: {}, isowner: false, notes: []} + }; + <body .f6.dark-gray.helvetica> + ^{pageBody pc} diff --git a/templates/user.hamlet b/templates/user.hamlet index 12d7904..37138b2 100644 --- a/templates/user.hamlet +++ b/templates/user.hamlet @@ -1,61 +1,61 @@ -$maybe route <- mroute - <main #main_column .pv2.ph3.mh1> - <div .w-100.mw8.center> - <div .fr.nt1 style="margin-bottom:.7rem"> - ^{search} - <div .di> - <div .fl.pr3.dib.mb2> - <b> - <a .link href="@{UserR unamep}">#{uname} - $forall tag <- pathtags - \ + # - <a .link href="@{UserTagsR unamep (TagsP [tag])}">#{tag} - <div .fl.pr3.dib.mb2> - <span .f7.silver>#{bcount}</span> - $if isowner - <div .fl.pr3.dib.mb2> - <a .link.silver.hover-blue :isAll:.nav-active - href="@{UserR unamep}">all - ‧ - <a .link.silver.hover-blue :sharedp == SharedPrivate:.nav-active - href="@{UserSharedR unamep SharedPrivate}">private - ‧ - <a .link.silver.hover-blue :sharedp == SharedPublic:.nav-active - href="@{UserSharedR unamep SharedPublic}">public - ‧ - <a .link.silver.hover-blue :filterp == FilterUnread:.nav-active - href="@{UserFilterR unamep FilterUnread}">unread - ‧ - <a .link.silver.hover-blue :filterp == FilterUntagged:.nav-active - href="@{UserFilterR unamep FilterUntagged}">untagged - ‧ - <a .link.silver.hover-blue :filterp == FilterStarred:.nav-active - href="@{UserFilterR unamep FilterStarred}">starred - <div .fr.f6.pr3.dib.mb2> - <a .link.gold.hover-orange - href="@{UserFeedR unamep}">RSS - - <div .cf> - - ^{pager} - - <div .cf> - - <div ##{tagCloudRenderEl}> - - <div ##{renderEl} .mt3> - - <div .cf> - - <div .user_footer.view-delay> - ^{pager} - - $if (fromIntegral bcount >= limit) || (page > 1) - <div .dib.ml5> - <span .silver.mr1>per page: - <a .link.light-silver :limit == 20:.nav-active href="@?{(route, catMaybes [Just ("count", "20"), mqueryp])}"‧>20</a> ‧ - <a .link.light-silver :limit == 40:.nav-active href="@?{(route, catMaybes [Just ("count", "40"), mqueryp])}"‧>40</a> ‧ - <a .link.light-silver :limit == 80:.nav-active href="@?{(route, catMaybes [Just ("count", "80"), mqueryp])}"‧>80</a> ‧ - <a .link.light-silver :limit == 120:.nav-active href="@?{(route, catMaybes [Just ("count", "120"), mqueryp])}"‧>120</a> ‧ - <a .link.light-silver :limit == 160:.nav-active href="@?{(route, catMaybes [Just ("count", "160"), mqueryp])}"‧>160</a> - +$maybe route <- mroute + <main #main_column .pv2.ph3.mh1> + <div .w-100.mw8.center> + <div .fr.nt1 style="margin-bottom:.7rem"> + ^{search} + <div .di> + <div .fl.pr3.dib.mb2> + <b> + <a .link href="@{UserR unamep}">#{uname} + $forall tag <- pathtags + \ + # + <a .link href="@{UserTagsR unamep (TagsP [tag])}">#{tag} + <div .fl.pr3.dib.mb2> + <span .f7.silver>#{bcount}</span> + $if isowner + <div .fl.pr3.dib.mb2> + <a .link.silver.hover-blue :isAll:.nav-active + href="@{UserR unamep}">all + ‧ + <a .link.silver.hover-blue :sharedp == SharedPrivate:.nav-active + href="@{UserSharedR unamep SharedPrivate}">private + ‧ + <a .link.silver.hover-blue :sharedp == SharedPublic:.nav-active + href="@{UserSharedR unamep SharedPublic}">public + ‧ + <a .link.silver.hover-blue :filterp == FilterUnread:.nav-active + href="@{UserFilterR unamep FilterUnread}">unread + ‧ + <a .link.silver.hover-blue :filterp == FilterUntagged:.nav-active + href="@{UserFilterR unamep FilterUntagged}">untagged + ‧ + <a .link.silver.hover-blue :filterp == FilterStarred:.nav-active + href="@{UserFilterR unamep FilterStarred}">starred + <div .fr.f6.pr3.dib.mb2> + <a .link.gold.hover-orange + href="@{UserFeedR unamep}">RSS + + <div .cf> + + ^{pager} + + <div .cf> + + <div ##{tagCloudRenderEl}> + + <div ##{renderEl} .mt3> + + <div .cf> + + <div .user_footer.view-delay> + ^{pager} + + $if (fromIntegral bcount >= limit) || (page > 1) + <div .dib.ml5> + <span .silver.mr1>per page: + <a .link.light-silver :limit == 20:.nav-active href="@?{(route, catMaybes [Just ("count", "20"), mqueryp])}"‧>20</a> ‧ + <a .link.light-silver :limit == 40:.nav-active href="@?{(route, catMaybes [Just ("count", "40"), mqueryp])}"‧>40</a> ‧ + <a .link.light-silver :limit == 80:.nav-active href="@?{(route, catMaybes [Just ("count", "80"), mqueryp])}"‧>80</a> ‧ + <a .link.light-silver :limit == 120:.nav-active href="@?{(route, catMaybes [Just ("count", "120"), mqueryp])}"‧>120</a> ‧ + <a .link.light-silver :limit == 160:.nav-active href="@?{(route, catMaybes [Just ("count", "160"), mqueryp])}"‧>160</a> +