yogsototh/espial
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Merge pull request #3 from yogsototh/public-notes-with-feed

Browse source 
Public notes with feed
This commit is contained in:
Jon Schoning 2019-09-15 12:25:45 -05:00 committed by GitHub
parent 93199f62f9 0dbad04c35
commit 1721fe2544
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
16 changed files with 211 additions and 87 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
config/routes
View file

@ -8,6 +8,7 @@
-- notes -- notes
!/#UserNameP/notes NotesR GET !/#UserNameP/notes NotesR GET
!/#UserNameP/notes/add AddNoteViewR GET !/#UserNameP/notes/add AddNoteViewR GET
!/#UserNameP/notes/feed.xml NotesFeedR GET
!/#UserNameP/notes/#NtSlug NoteR GET !/#UserNameP/notes/#NtSlug NoteR GET
!/api/note/add AddNoteR POST !/api/note/add AddNoteR POST
!/api/note/#Int64 DeleteNoteR DELETE !/api/note/#Int64 DeleteNoteR DELETE
@ -18,6 +19,7 @@
!/#UserNameP/#SharedP UserSharedR GET !/#UserNameP/#SharedP UserSharedR GET
!/#UserNameP/#FilterP UserFilterR GET !/#UserNameP/#FilterP UserFilterR GET
!/#UserNameP/#TagsP UserTagsR GET !/#UserNameP/#TagsP UserTagsR GET
!/#UserNameP/feed.xml UserFeedR GET
-- settings -- settings
/Settings AccountSettingsR GET /Settings AccountSettingsR GET

10
espial.cabal
View file

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: ac9856c342ac9d7c05b18be91fb062e098dbf3575b2fbe7293f69df2d5b76cce -- hash: da944088abb7ae887d67efd710c100bdbd5587072c6ddcfdc5d05392e7509d85
name: espial name: espial
version: 0.0.8 version: 0.0.8
@ -128,6 +128,7 @@ library
, attoparsec , attoparsec
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
, bcrypt >=0.0.8 , bcrypt >=0.0.8
, blaze-html >=0.9 && <1.0
, bytestring >=0.9 && <0.11 , bytestring >=0.9 && <0.11
, case-insensitive , case-insensitive
, classy-prelude >=1.4 && <1.6 , classy-prelude >=1.4 && <1.6
@ -179,6 +180,7 @@ library
, yesod-auth >=1.6 && <1.7 , yesod-auth >=1.6 && <1.7
, yesod-core >=1.6 && <1.7 , yesod-core >=1.6 && <1.7
, yesod-form >=1.6 && <1.7 , yesod-form >=1.6 && <1.7
, yesod-newsfeed >=1.6 && <1.7
, yesod-static >=1.6 && <1.7 , yesod-static >=1.6 && <1.7
if (flag(dev)) || (flag(library-only)) if (flag(dev)) || (flag(library-only))
ghc-options: -Wall -fwarn-tabs -O0 ghc-options: -Wall -fwarn-tabs -O0
@ -201,6 +203,7 @@ executable espial
, attoparsec , attoparsec
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
, bcrypt >=0.0.8 , bcrypt >=0.0.8
, blaze-html >=0.9 && <1.0
, bytestring >=0.9 && <0.11 , bytestring >=0.9 && <0.11
, case-insensitive , case-insensitive
, classy-prelude >=1.4 && <1.6 , classy-prelude >=1.4 && <1.6
@ -253,6 +256,7 @@ executable espial
, yesod-auth >=1.6 && <1.7 , yesod-auth >=1.6 && <1.7
, yesod-core >=1.6 && <1.7 , yesod-core >=1.6 && <1.7
, yesod-form >=1.6 && <1.7 , yesod-form >=1.6 && <1.7
, yesod-newsfeed >=1.6 && <1.7
, yesod-static >=1.6 && <1.7 , yesod-static >=1.6 && <1.7
if flag(library-only) if flag(library-only)
buildable: False buildable: False
@ -271,6 +275,7 @@ executable migration
, attoparsec , attoparsec
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
, bcrypt >=0.0.8 , bcrypt >=0.0.8
, blaze-html >=0.9 && <1.0
, bytestring >=0.9 && <0.11 , bytestring >=0.9 && <0.11
, case-insensitive , case-insensitive
, classy-prelude >=1.4 && <1.6 , classy-prelude >=1.4 && <1.6
@ -324,6 +329,7 @@ executable migration
, yesod-auth >=1.6 && <1.7 , yesod-auth >=1.6 && <1.7
, yesod-core >=1.6 && <1.7 , yesod-core >=1.6 && <1.7
, yesod-form >=1.6 && <1.7 , yesod-form >=1.6 && <1.7
, yesod-newsfeed >=1.6 && <1.7
, yesod-static >=1.6 && <1.7 , yesod-static >=1.6 && <1.7
if flag(library-only) if flag(library-only)
buildable: False buildable: False
@ -346,6 +352,7 @@ test-suite test
, attoparsec , attoparsec
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
, bcrypt >=0.0.8 , bcrypt >=0.0.8
, blaze-html >=0.9 && <1.0
, bytestring >=0.9 && <0.11 , bytestring >=0.9 && <0.11
, case-insensitive , case-insensitive
, classy-prelude >=1.4 && <1.6 , classy-prelude >=1.4 && <1.6
@ -399,6 +406,7 @@ test-suite test
, yesod-auth >=1.6 && <1.7 , yesod-auth >=1.6 && <1.7
, yesod-core >=1.6 && <1.7 , yesod-core >=1.6 && <1.7
, yesod-form >=1.6 && <1.7 , yesod-form >=1.6 && <1.7
, yesod-newsfeed >=1.6 && <1.7
, yesod-static >=1.6 && <1.7 , yesod-static >=1.6 && <1.7
, yesod-test , yesod-test
default-language: Haskell2010 default-language: Haskell2010

2
package.yaml
View file

@ -86,6 +86,7 @@ dependencies:
- yesod-auth >=1.6 && <1.7 - yesod-auth >=1.6 && <1.7
- yesod-static >=1.6 && <1.7 - yesod-static >=1.6 && <1.7
- yesod-form >=1.6 && <1.7 - yesod-form >=1.6 && <1.7
- yesod-newsfeed >= 1.6 && < 1.7
- classy-prelude >=1.4 && <1.6 - classy-prelude >=1.4 && <1.6
- classy-prelude-conduit >=1.4 && <1.6 - classy-prelude-conduit >=1.4 && <1.6
- classy-prelude-yesod >=1.4 && <1.6 - classy-prelude-yesod >=1.4 && <1.6
@ -93,6 +94,7 @@ dependencies:
- text >=0.11 && <2.0 - text >=0.11 && <2.0
- persistent >=2.8 && <2.10 - persistent >=2.8 && <2.10
# - persistent-postgresql >=2.8 && <2.9 # - persistent-postgresql >=2.8 && <2.9
- blaze-html >= 0.9 && < 1.0
- persistent-template >=2.5 && <2.9 - persistent-template >=2.5 && <2.9
- template-haskell - template-haskell
- shakespeare >=2.0 && <2.1 - shakespeare >=2.0 && <2.1

20
purs/src/Component/NList.purs
View file

@ -48,19 +48,23 @@ nlist st' =
render st@{ notes } = render st@{ notes } =
HH.div_ (map renderNote notes) HH.div_ (map renderNote notes)
where where
renderNote bm = renderNote note =
div [ id_ (show bm.id) , class_ ("note w-100 mw7 pa1 mb2")] $ div [ id_ (show note.id)
, class_ ("note w-100 mw7 pa1 mb2"
<> if note.shared then "" else " private")] $
[ div [ class_ "display" ] $ [ div [ class_ "display" ] $
[ a [ href (linkToFilterSingle bm.slug), class_ ("link f5 lh-title")] [ a [ href (linkToFilterSingle note.slug), class_ ("link f5 lh-title")]
[ text $ if S.null bm.title then "[no title]" else bm.title ] [ text $ if S.null note.title then "[no title]" else note.title ]
, br_ , br_
, div [ class_ "description mt1 mid-gray" ] (toTextarea (S.take 200 bm.text)) , div [ class_ "description mt1 mid-gray" ] (toTextarea (S.take 200 note.text))
, a [ class_ "link f7 dib gray w4", title (maybe bm.created snd (mmoment bm)) , href (linkToFilterSingle bm.slug) ] , a [ class_ "link f7 dib gray w4"
[ text (maybe " " fst (mmoment bm)) ] , title (maybe note.created snd (mmoment note))
, href (linkToFilterSingle note.slug)]
[text (maybe " " fst (mmoment note))]
] ]
] ]
mmoment bm = mmoment8601 bm.created mmoment note = mmoment8601 note.created
linkToFilterSingle slug = fromNullableStr app.userR <> "/notes/" <> slug linkToFilterSingle slug = fromNullableStr app.userR <> "/notes/" <> slug
toTextarea input = toTextarea input =
S.split (Pattern "\n") input S.split (Pattern "\n") input

30
purs/src/Component/NNote.purs
View file

@ -51,11 +51,12 @@ _edit_note = lens _.edit_note (_ { edit_note = _ })
_edit :: Lens' NState Boolean _edit :: Lens' NState Boolean
_edit = lens _.edit (_ { edit = _ }) _edit = lens _.edit (_ { edit = _ })
-- | FormField Edits -- | FormField Edits
data EditField data EditField
= Etitle String = Etitle String
| Etext String | Etext String
| EisMarkdown Boolean | EisMarkdown Boolean
| Eshared Boolean
_markdown = SProxy :: SProxy "markdown" _markdown = SProxy :: SProxy "markdown"
@ -99,8 +100,13 @@ nnote st' =
, if note.isMarkdown , if note.isMarkdown
then div [ class_ "description mt1" ] [ HH.slot _markdown unit Markdown.component note.text absurd ] then div [ class_ "description mt1" ] [ HH.slot _markdown unit Markdown.component note.text absurd ]
else div [ class_ "description mt1 mid-gray" ] (toTextarea note.text) else div [ class_ "description mt1 mid-gray" ] (toTextarea note.text)
, div [ class_ "link f7 dib gray w4", title (maybe note.created snd (mmoment note)) ] , div [ class_ "link f7 dib gray w4"]
[ text (maybe " " fst (mmoment note)) ] [ span [title (maybe note.created snd (mmoment note))]
[text (maybe " " fst (mmoment note))]
, text " - "
, span [ class_ ("gray")]
[ text $ if note.shared then "public" else "private" ]
]
] ]
] ]
<> -- | Render Action Links <> -- | Render Action Links
@ -111,7 +117,7 @@ nnote st' =
, span ([ class_ ("confirm red" <> guard (not st.deleteAsk) " dn") ] ) , span ([ class_ ("confirm red" <> guard (not st.deleteAsk) " dn") ] )
[ button [ type_ ButtonButton, onClick \_ -> Just (NDeleteAsk false)] [ text "cancel / " ] [ button [ type_ ButtonButton, onClick \_ -> Just (NDeleteAsk false)] [ text "cancel / " ]
, button [ type_ ButtonButton, onClick \_ -> Just NDestroy, class_ "red" ] [ text "destroy" ] , button [ type_ ButtonButton, onClick \_ -> Just NDestroy, class_ "red" ] [ text "destroy" ]
] ]
] ]
] ]
] ]
@ -134,9 +140,20 @@ nnote st' =
, label [ for "edit_ismarkdown" , class_ "mr2" ] [ text "use markdown?" ] , label [ for "edit_ismarkdown" , class_ "mr2" ] [ text "use markdown?" ]
, br_ , br_
] ]
, input [ type_ InputSubmit , class_ "mr1 pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "save" ] , div [ class_ "edit_form_checkboxes mb3"]
[ input [ type_ InputCheckbox , class_ "is-markdown pointer" , id_ "edit_shared", name "shared"
, checked (edit_note.shared) , onChecked (editField Eshared) ]
, text " "
, label [ for "edit_shared" , class_ "mr2" ] [ text "public?" ]
, br_
]
, input [ type_ InputSubmit
, class_ "mr1 pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim"
, value "save" ]
, text " " , text " "
, input [ type_ InputReset , class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "cancel" , input [ type_ InputReset
, class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim"
, value "cancel"
, onClick \_ -> Just (NEdit false) , onClick \_ -> Just (NEdit false)
] ]
] ]
@ -161,6 +178,7 @@ nnote st' =
Etitle e -> _ { title = e } Etitle e -> _ { title = e }
Etext e -> _ { text = e } Etext e -> _ { text = e }
EisMarkdown e -> _ { isMarkdown = e } EisMarkdown e -> _ { isMarkdown = e }
Eshared e -> _ { shared = e }
-- | Delete -- | Delete
handleAction (NDeleteAsk e) = do handleAction (NDeleteAsk e) = do

1
purs/src/Model.purs
View file

@ -34,6 +34,7 @@ type Note =
, text :: String , text :: String
, length :: Int , length :: Int
, isMarkdown :: Boolean , isMarkdown :: Boolean
, shared :: Boolean
, created :: String , created :: String
, updated :: String , updated :: String
} }

62
src/Application.hs
View file

@ -14,43 +14,37 @@ module Application
, db , db
) where ) where
import Control.Monad.Logger (liftLoc, runLoggingT) import Control.Monad.Logger (liftLoc, runLoggingT)
import Database.Persist.Sqlite import Database.Persist.Sqlite (createSqlitePool, runSqlPool, sqlDatabase, sqlPoolSize)
(createSqlitePool, sqlDatabase, sqlPoolSize) import Import
import Import import Language.Haskell.TH.Syntax (qLocation)
import Yesod.Auth (getAuth) import Lens.Micro
import Language.Haskell.TH.Syntax (qLocation) import Network.HTTP.Client.TLS
import Lens.Micro import Network.Wai (Middleware)
import Network.HTTP.Client.TLS import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, runSettings, setHost, setOnException, setPort, getPort)
import Network.Wai (Middleware) import Network.Wai.Middleware.AcceptOverride
import Network.Wai.Middleware.Autohead import Network.Wai.Middleware.Autohead
import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.MethodOverride
import Network.Wai.Middleware.MethodOverride import Network.Wai.Middleware.RequestLogger (Destination(Logger), IPAddrSource(..), OutputFormat(..), destination, mkRequestLogger, outputFormat)
import Network.Wai.Handler.Warp import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
(Settings, defaultSettings, defaultShouldDisplayException, import Yesod.Auth (getAuth)
runSettings, setHost, setOnException, setPort, getPort)
import Network.Wai.Middleware.RequestLogger
(Destination(Logger), IPAddrSource(..), OutputFormat(..),
destination, mkRequestLogger, outputFormat)
import System.Log.FastLogger
(defaultBufSize, newStdoutLoggerSet, toLogStr)
import qualified Control.Monad.Metrics as MM import qualified Control.Monad.Metrics as MM
import qualified Network.Wai.Metrics as WM import qualified Network.Wai.Metrics as WM
import qualified System.Metrics as EKG import qualified System.Metrics as EKG
import qualified System.Remote.Monitoring as EKG import qualified System.Remote.Monitoring as EKG
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!
import Handler.Common import Handler.Common
import Handler.Home import Handler.Home
import Handler.User import Handler.User
import Handler.AccountSettings import Handler.AccountSettings
import Handler.Add import Handler.Add
import Handler.Edit import Handler.Edit
import Handler.Notes import Handler.Notes
import Handler.Docs import Handler.Docs
mkYesodDispatch "App" resourcesApp mkYesodDispatch "App" resourcesApp
@ -74,9 +68,9 @@ makeFoundation appSettings = do
createSqlitePool createSqlitePool
(sqlDatabase (appDatabaseConf appSettings)) (sqlDatabase (appDatabaseConf appSettings))
(sqlPoolSize (appDatabaseConf appSettings)) (sqlPoolSize (appDatabaseConf appSettings))
-- runLoggingT runLoggingT
-- (runSqlPool runMigrations pool) (runSqlPool runMigrations pool)
-- logFunc logFunc
return (mkFoundation pool) return (mkFoundation pool)
makeApplication :: App -> IO Application makeApplication :: App -> IO Application

65
src/Handler/Notes.hs
View file

@ -5,30 +5,34 @@ import Import
import Handler.Common (lookupPagingParams) import Handler.Common (lookupPagingParams)
import qualified Data.Aeson as A import qualified Data.Aeson as A
import qualified Data.Text as T import qualified Data.Text as T
import Yesod.RssFeed
import Text.Blaze.Html (toHtml)
import qualified Text.Blaze.Html5 as H
getNotesR :: UserNameP -> Handler Html getNotesR :: UserNameP -> Handler Html
getNotesR unamep@(UserNameP uname) = do getNotesR unamep@(UserNameP uname) = do
void requireAuthId muserid <- maybeAuthId
(limit', page') <- lookupPagingParams (limit', page') <- lookupPagingParams
let queryp = "query" :: Text let queryp = "query" :: Text
mquery <- lookupGetParam queryp mquery <- lookupGetParam queryp
let limit = maybe 20 fromIntegral limit' let limit = maybe 20 fromIntegral limit'
page = maybe 1 fromIntegral page' page = maybe 1 fromIntegral page'
mqueryp = fmap (\q -> (queryp, q)) mquery mqueryp = fmap (\q -> (queryp, q)) mquery
(bcount, notes) <- (bcount, notes) <- runDB $ do
runDB $ Entity userId _ <- getBy404 (UniqueUserName uname)
do Entity userId _ <- getBy404 (UniqueUserName uname) let sharedp = if muserid == Just userId then SharedAll else SharedPublic
getNoteList userId mquery limit page getNoteList userId mquery sharedp limit page
req <- getRequest req <- getRequest
mroute <- getCurrentRoute mroute <- getCurrentRoute
defaultLayout $ do defaultLayout $ do
rssLink (NotesFeedR unamep) "feed"
let pager = $(widgetFile "pager") let pager = $(widgetFile "pager")
search = $(widgetFile "search") search = $(widgetFile "search")
renderEl = "notes" :: Text renderEl = "notes" :: Text
$(widgetFile "notes") $(widgetFile "notes")
toWidgetBody [julius| toWidgetBody [julius|
app.userR = "@{UserR unamep}"; app.userR = "@{UserR unamep}";
app.dat.notes = #{ toJSON notes } || []; app.dat.notes = #{ toJSON notes } || [];
|] |]
toWidget [julius| toWidget [julius|
PS['Main'].renderNotes('##{rawJS renderEl}')(app.dat.notes)(); PS['Main'].renderNotes('##{rawJS renderEl}')(app.dat.notes)();
@ -36,7 +40,6 @@ getNotesR unamep@(UserNameP uname) = do
getNoteR :: UserNameP -> NtSlug -> Handler Html getNoteR :: UserNameP -> NtSlug -> Handler Html
getNoteR unamep@(UserNameP uname) slug = do getNoteR unamep@(UserNameP uname) slug = do
void requireAuthId
let renderEl = "note" :: Text let renderEl = "note" :: Text
note <- note <-
runDB $ runDB $
@ -47,7 +50,7 @@ getNoteR unamep@(UserNameP uname) slug = do
$(widgetFile "note") $(widgetFile "note")
toWidgetBody [julius| toWidgetBody [julius|
app.userR = "@{UserR unamep}"; app.userR = "@{UserR unamep}";
app.dat.note = #{ toJSON note } || []; app.dat.note = #{ toJSON note } || [];
|] |]
toWidget [julius| toWidget [julius|
PS['Main'].renderNote('##{rawJS renderEl}')(app.dat.note)(); PS['Main'].renderNote('##{rawJS renderEl}')(app.dat.note)();
@ -57,13 +60,13 @@ getAddNoteViewR :: UserNameP -> Handler Html
getAddNoteViewR unamep@(UserNameP uname) = do getAddNoteViewR unamep@(UserNameP uname) = do
userId <- requireAuthId userId <- requireAuthId
let renderEl = "note" :: Text let renderEl = "note" :: Text
note <- liftIO $ Entity (NoteKey 0) <$> _toNote userId (NoteForm Nothing Nothing Nothing Nothing Nothing Nothing Nothing) note <- liftIO $ Entity (NoteKey 0) <$> _toNote userId (NoteForm Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
defaultLayout $ do defaultLayout $ do
$(widgetFile "note") $(widgetFile "note")
toWidgetBody [julius| toWidgetBody [julius|
app.userR = "@{UserR unamep}"; app.userR = "@{UserR unamep}";
app.noteR = "@{NoteR unamep (noteSlug (entityVal note))}"; app.noteR = "@{NoteR unamep (noteSlug (entityVal note))}";
app.dat.note = #{ toJSON note } || []; app.dat.note = #{ toJSON note } || [];
|] |]
toWidget [julius| toWidget [julius|
PS['Main'].renderNote('##{rawJS renderEl}')(app.dat.note)(); PS['Main'].renderNote('##{rawJS renderEl}')(app.dat.note)();
@ -106,6 +109,7 @@ data NoteForm = NoteForm
, _title :: Maybe Text , _title :: Maybe Text
, _text :: Maybe Textarea , _text :: Maybe Textarea
, _isMarkdown :: Maybe Bool , _isMarkdown :: Maybe Bool
, _shared :: Maybe Bool
, _created :: Maybe UTCTimeStr , _created :: Maybe UTCTimeStr
, _updated :: Maybe UTCTimeStr , _updated :: Maybe UTCTimeStr
} deriving (Show, Eq, Read, Generic) } deriving (Show, Eq, Read, Generic)
@ -114,7 +118,7 @@ instance FromJSON NoteForm where parseJSON = A.genericParseJSON gNoteFormOptions
instance ToJSON NoteForm where toJSON = A.genericToJSON gNoteFormOptions instance ToJSON NoteForm where toJSON = A.genericToJSON gNoteFormOptions
gNoteFormOptions :: A.Options gNoteFormOptions :: A.Options
gNoteFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 } gNoteFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 }
_toNote :: UserId -> NoteForm -> IO Note _toNote :: UserId -> NoteForm -> IO Note
_toNote userId NoteForm {..} = do _toNote userId NoteForm {..} = do
@ -128,5 +132,40 @@ _toNote userId NoteForm {..} = do
(fromMaybe "" _title) (fromMaybe "" _title)
(maybe "" unTextarea _text) (maybe "" unTextarea _text)
(fromMaybe False _isMarkdown) (fromMaybe False _isMarkdown)
(fromMaybe False _shared)
(fromMaybe time (fmap unUTCTimeStr _created)) (fromMaybe time (fmap unUTCTimeStr _created))
(fromMaybe time (fmap unUTCTimeStr _updated)) (fromMaybe time (fmap unUTCTimeStr _updated))
noteToRssEntry :: UserNameP -> Entity Note -> FeedEntry (Route App)
noteToRssEntry usernamep (Entity entryId entry) =
FeedEntry { feedEntryLink = NoteR usernamep (noteSlug entry)
, feedEntryUpdated = (noteUpdated entry)
, feedEntryTitle = (noteTitle entry)
, feedEntryContent = (toHtml (noteText entry))
, feedEntryEnclosure = Nothing
}
getNotesFeedR :: UserNameP -> Handler RepRss
getNotesFeedR unamep@(UserNameP uname) = do
(limit', page') <- lookupPagingParams
let queryp = "query" :: Text
mquery <- lookupGetParam queryp
let limit = maybe 20 fromIntegral limit'
page = maybe 1 fromIntegral page'
(bcount, notes) <- runDB $ do
Entity userId _ <- getBy404 (UniqueUserName uname)
getNoteList userId mquery SharedPublic limit page
let (descr :: Html) = toHtml $ H.text (uname <> " notes")
let entries = map (noteToRssEntry unamep) notes
updated <- case maximumMay (map feedEntryUpdated entries) of
Nothing -> liftIO $ getCurrentTime
Just m -> return m
rssFeed $ Feed (uname <> " notes")
(NotesFeedR unamep)
(NotesR unamep)
uname
descr
"en"
updated
Nothing
entries

53
src/Handler/User.hs
View file

@ -1,9 +1,12 @@
{-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-}
module Handler.User where module Handler.User where
import Import
import qualified Data.Text as T import qualified Data.Text as T
import Handler.Common (lookupPagingParams) import Handler.Common (lookupPagingParams)
import Import
import Text.Blaze.Html (toHtml)
import qualified Text.Blaze.Html5 as H
import Yesod.RssFeed
getUserR :: UserNameP -> Handler Html getUserR :: UserNameP -> Handler Html
getUserR uname@(UserNameP name) = do getUserR uname@(UserNameP name) = do
@ -35,7 +38,7 @@ _getUser unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do
isAll = filterp == FilterAll && sharedp == SharedAll && pathtags == [] isAll = filterp == FilterAll && sharedp == SharedAll && pathtags == []
queryp = "query" :: Text queryp = "query" :: Text
mquery <- lookupGetParam queryp mquery <- lookupGetParam queryp
let mqueryp = fmap (\q -> (queryp, q)) mquery let mqueryp = fmap (\q -> (queryp, q)) mquery
(bcount, bmarks, alltags) <- (bcount, bmarks, alltags) <-
runDB $ runDB $
do Entity userId user <- getBy404 (UniqueUserName uname) do Entity userId user <- getBy404 (UniqueUserName uname)
@ -45,18 +48,58 @@ _getUser unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do
tg <- tagsQuery bm tg <- tagsQuery bm
pure (cnt, bm, tg) pure (cnt, bm, tg)
when (bcount == 0) (case filterp of FilterSingle _ -> notFound; _ -> pure ()) when (bcount == 0) (case filterp of FilterSingle _ -> notFound; _ -> pure ())
mroute <- getCurrentRoute mroute <- getCurrentRoute
req <- getRequest req <- getRequest
defaultLayout $ do defaultLayout $ do
let pager = $(widgetFile "pager") let pager = $(widgetFile "pager")
search = $(widgetFile "search") search = $(widgetFile "search")
renderEl = "bookmarks" :: Text renderEl = "bookmarks" :: Text
rssLink (UserFeedR unamep) "feed"
$(widgetFile "user") $(widgetFile "user")
toWidgetBody [julius| toWidgetBody [julius|
app.dat.bmarks = #{ toJSON $ toBookmarkFormList bmarks alltags } || []; app.dat.bmarks = #{ toJSON $ toBookmarkFormList bmarks alltags } || [];
app.dat.isowner = #{ isowner }; app.dat.isowner = #{ isowner };
app.userR = "@{UserR unamep}"; app.userR = "@{UserR unamep}";
|] |]
toWidget [julius| toWidget [julius|
PS['Main'].renderBookmarks('##{rawJS renderEl}')(app.dat.bmarks)(); PS['Main'].renderBookmarks('##{rawJS renderEl}')(app.dat.bmarks)();
|] |]
bookmarkToRssEntry :: Entity Bookmark -> FeedEntry Text
bookmarkToRssEntry (Entity entryId entry) =
FeedEntry { feedEntryLink = (bookmarkHref entry)
, feedEntryUpdated = (bookmarkTime entry)
, feedEntryTitle = (bookmarkDescription entry)
, feedEntryContent = (toHtml (bookmarkExtended entry))
, feedEntryEnclosure = Nothing
}
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
mquery <- lookupGetParam queryp
(bcount, bmarks, alltags) <-
runDB $
do Entity userId user <- getBy404 (UniqueUserName uname)
(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)
let entries = map bookmarkToRssEntry bmarks
updated <- case maximumMay (map feedEntryUpdated entries) of
Nothing -> liftIO $ getCurrentTime
Just m -> return m
render <- getUrlRender
rssFeedText $ Feed ("espial " <> uname)
(render (UserFeedR unamep))
(render (UserR unamep))
uname
descr
"en"
updated
Nothing
entries

40
src/Model.hs
View file

@ -26,7 +26,7 @@ import qualified Data.Map.Strict as MS
import ModelCustom import ModelCustom
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase| share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase|
User json User json
Id Int64 Id Int64
name Text name Text
@ -72,6 +72,7 @@ Note json
title Text title Text
text Text text Text
isMarkdown Bool isMarkdown Bool
shared Bool default=False
created UTCTime created UTCTime
updated UTCTime updated UTCTime
deriving Show Eq Typeable Ord deriving Show Eq Typeable Ord
@ -151,7 +152,7 @@ authenticatePassword username password = do
if validatePasswordHash (userPasswordHash (entityVal dbuser)) password if validatePasswordHash (userPasswordHash (entityVal dbuser)) password
then return (Just dbuser) then return (Just dbuser)
else return Nothing else return Nothing
getUserByName :: UserNameP -> DB (Maybe (Entity User)) getUserByName :: UserNameP -> DB (Maybe (Entity User))
getUserByName (UserNameP uname) = do getUserByName (UserNameP uname) = do
selectFirst [UserName ==. uname] [] selectFirst [UserName ==. uname] []
@ -187,7 +188,7 @@ bookmarksQuery userId sharedp filterp tags mquery limit' page =
expr &&. (exists $ -- each tag becomes an exists constraint expr &&. (exists $ -- each tag becomes an exists constraint
from $ \t -> from $ \t ->
where_ (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId &&. where_ (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId &&.
(t ^. BookmarkTagTag `E.like` val tag)))) (t ^. BookmarkTagTag `E.like` val tag))))
(b ^. BookmarkUserId E.==. val userId) (b ^. BookmarkUserId E.==. val userId)
tags tags
case sharedp of case sharedp of
@ -242,7 +243,7 @@ parseSearchQuery toExpr =
termE = toExpr <$> (fieldTerm <|> quotedTerm <|> simpleTerm) termE = toExpr <$> (fieldTerm <|> quotedTerm <|> simpleTerm)
fieldTerm = concat <$> sequence [simpleTerm, P.string ":", quotedTerm <|> simpleTerm] fieldTerm = concat <$> sequence [simpleTerm, P.string ":", quotedTerm <|> simpleTerm]
quotedTerm = PC.between (P.char '"') (P.char '"') (P.takeWhile1 (/= '"')) quotedTerm = PC.between (P.char '"') (P.char '"') (P.takeWhile1 (/= '"'))
simpleTerm = P.takeWhile1 (\c -> not (isSpace c) && c /= ':' && c /= '|') simpleTerm = P.takeWhile1 (\c -> not (isSpace c) && c /= ':' && c /= '|')
parseTimeText :: (TI.ParseTime t, Monad m, Alternative m) => Text -> m t parseTimeText :: (TI.ParseTime t, Monad m, Alternative m) => Text -> m t
parseTimeText t = parseTimeText t =
@ -267,13 +268,13 @@ withTags key = selectList [BookmarkTagBookmarkId ==. key] [Asc BookmarkTagSeq]
-- Note List Query -- Note List Query
getNote :: Key User -> NtSlug -> DB (Maybe (Entity Note)) getNote :: Key User -> NtSlug -> DB (Maybe (Entity Note))
getNote userKey slug = getNote userKey slug =
selectFirst [NoteUserId ==. userKey, NoteSlug ==. slug] [] selectFirst [NoteUserId ==. userKey, NoteSlug ==. slug] []
getNoteList :: Key User -> Maybe Text -> Limit -> Page -> DB (Int, [Entity Note]) getNoteList :: Key User -> Maybe Text -> SharedP -> Limit -> Page -> DB (Int, [Entity Note])
getNoteList key mquery limit' page = getNoteList key mquery sharedp limit' page =
(,) -- total count (,) -- total count
<$> fmap (sum . fmap E.unValue) <$> fmap (sum . fmap E.unValue)
(select $ (select $
@ -292,6 +293,10 @@ getNoteList key mquery limit' page =
where_ $ (b ^. NoteUserId E.==. val key) where_ $ (b ^. NoteUserId E.==. val key)
-- search -- search
sequenceA_ (parseSearchQuery (toLikeExpr b) =<< mquery) 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 :: E.SqlExpr (Entity Note) -> Text -> E.SqlExpr (E.Value Bool)
toLikeExpr b term = fromRight p_allFields (P.parseOnly p_onefield term) toLikeExpr b term = fromRight p_allFields (P.parseOnly p_onefield term)
@ -415,6 +420,7 @@ fileNoteToNote user (FileNote {..} ) = do
fileNoteTitle fileNoteTitle
fileNoteText fileNoteText
False False
False
fileNoteCreatedAt fileNoteCreatedAt
fileNoteUpdatedAt fileNoteUpdatedAt
@ -425,19 +431,19 @@ insertDirFileNotes userId noteDirectory = do
Left e -> print e Left e -> print e
Right fnotes -> do Right fnotes -> do
notes <- liftIO $ mapM (fileNoteToNote userId) fnotes notes <- liftIO $ mapM (fileNoteToNote userId) fnotes
void $ mapM insertUnique notes void $ mapM insertUnique notes
where where
readFileNotes :: MonadIO m => FilePath -> m (Either String [FileNote]) readFileNotes :: MonadIO m => FilePath -> m (Either String [FileNote])
readFileNotes fdir = do readFileNotes fdir = do
files <- liftIO (listDirectory fdir) files <- liftIO (listDirectory fdir)
noteBSS <- mapM (readFile . (fdir </>)) files noteBSS <- mapM (readFile . (fdir </>)) files
pure (mapM (A.eitherDecode' . fromStrict) noteBSS) pure (mapM (A.eitherDecode' . fromStrict) noteBSS)
-- AccountSettingsForm -- AccountSettingsForm
data AccountSettingsForm = AccountSettingsForm data AccountSettingsForm = AccountSettingsForm
{ _privateDefault :: Bool { _privateDefault :: Bool
, _archiveDefault :: Bool , _archiveDefault :: Bool
, _privacyLock :: Bool , _privacyLock :: Bool
} deriving (Show, Eq, Read, Generic) } deriving (Show, Eq, Read, Generic)
instance FromJSON AccountSettingsForm where parseJSON = A.genericParseJSON gDefaultFormOptions instance FromJSON AccountSettingsForm where parseJSON = A.genericParseJSON gDefaultFormOptions
@ -479,7 +485,7 @@ instance FromJSON BookmarkForm where parseJSON = A.genericParseJSON gDefaultForm
instance ToJSON BookmarkForm where toJSON = A.genericToJSON gDefaultFormOptions instance ToJSON BookmarkForm where toJSON = A.genericToJSON gDefaultFormOptions
gDefaultFormOptions :: A.Options gDefaultFormOptions :: A.Options
gDefaultFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 } gDefaultFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 }
toBookmarkFormList :: [Entity Bookmark] -> [Entity BookmarkTag] -> [BookmarkForm] toBookmarkFormList :: [Entity Bookmark] -> [Entity BookmarkTag] -> [BookmarkForm]
toBookmarkFormList bs as = do toBookmarkFormList bs as = do
@ -533,7 +539,7 @@ upsertBookmark:: Maybe (Key Bookmark) -> Bookmark -> [Text] -> DB (UpsertResult,
upsertBookmark mbid bm tags = do upsertBookmark mbid bm tags = do
res <- case mbid of res <- case mbid of
Just bid -> do Just bid -> do
get bid >>= \case get bid >>= \case
Just prev_bm -> replaceBookmark bid prev_bm Just prev_bm -> replaceBookmark bid prev_bm
_ -> fail "not found" _ -> fail "not found"
Nothing -> do Nothing -> do
@ -542,7 +548,7 @@ upsertBookmark mbid bm tags = do
_ -> (Created,) <$> insert bm _ -> (Created,) <$> insert bm
insertTags (bookmarkUserId bm) (snd res) insertTags (bookmarkUserId bm) (snd res)
pure res pure res
where where
prepareReplace prev_bm = do prepareReplace prev_bm = do
if (bookmarkHref bm /= bookmarkHref prev_bm) if (bookmarkHref bm /= bookmarkHref prev_bm)
then bm { bookmarkArchiveHref = Nothing } then bm { bookmarkArchiveHref = Nothing }
@ -567,7 +573,7 @@ upsertNote:: Maybe (Key Note) -> Note -> DB (UpsertResult, Key Note)
upsertNote mnid bmark@Note{..} = do upsertNote mnid bmark@Note{..} = do
case mnid of case mnid of
Just nid -> do Just nid -> do
get nid >>= \case get nid >>= \case
Just _ -> do Just _ -> do
replace nid bmark replace nid bmark
pure (Updated, nid) pure (Updated, nid)

4
static/js/app.min.js vendored
View file

File diff suppressed because one or more lines are too long

BIN
static/js/app.min.js.gz
View file

Binary file not shown.

2
static/js/app.min.js.map
View file

File diff suppressed because one or more lines are too long

BIN
static/js/app.min.js.map.gz
View file

Binary file not shown.

4
templates/notes.hamlet
View file

@ -2,6 +2,10 @@
<div .w-100.mw8.center> <div .w-100.mw8.center>
<div .fr.nt1 style="margin-bottom:.7rem"> <div .fr.nt1 style="margin-bottom:.7rem">
^{search} ^{search}
<div .di>
<div .fr.f6.pr3.dib.mb2>
<a .link.gold.hover-orange
href="@{NotesFeedR unamep}">RSS
<span .db .mb3>#{T.append "" (maybe "You have" (const "Found") mquery)} #{bcount} notes: <span .db .mb3>#{T.append "" (maybe "You have" (const "Found") mquery)} #{bcount} notes:

3
templates/user.hamlet
View file

@ -31,6 +31,9 @@ $maybe route <- mroute
‧ ‧
<a .link.silver.hover-blue :filterp == FilterStarred:.nav-active <a .link.silver.hover-blue :filterp == FilterStarred:.nav-active
href="@{UserFilterR unamep FilterStarred}">starred href="@{UserFilterR unamep FilterStarred}">starred
<div .fr.f6.pr3.dib.mb2>
<a .link.gold.hover-orange
href="@{UserFeedR unamep}">RSS
<div .cf> <div .cf>