Ability to make notes public or shared

purs/src/Component/NList.purs

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

purs/src/Component/NNote.purs

@@ -51,11 +51,12 @@ _edit_note = lens _.edit_note (_ { edit_note = _ })
 _edit :: Lens' NState Boolean
 _edit = lens _.edit (_ { edit = _ })
 
--- | FormField Edits 
+-- | FormField Edits
 data EditField
   = Etitle String
   | Etext String
   | EisMarkdown Boolean
+  | Eshared Boolean
 
 _markdown = SProxy :: SProxy "markdown"
 
@@ -99,8 +100,13 @@ nnote st' =
              , if note.isMarkdown
                then div [ class_ "description mt1" ] [ HH.slot _markdown unit Markdown.component note.text absurd ]
                else div [ class_ "description mt1 mid-gray" ] (toTextarea note.text)
-             , div [ class_ "link f7 dib gray w4", title (maybe note.created snd (mmoment note)) ]
-               [ text (maybe " " fst (mmoment note)) ]
+             , div [ class_ "link f7 dib gray w4"]
+                 [ 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
@@ -111,7 +117,7 @@ nnote st' =
                , span ([ class_ ("confirm red" <> guard (not st.deleteAsk) " dn") ] )
                  [ button [ type_ ButtonButton, onClick \_ -> Just (NDeleteAsk false)] [ text "cancel / " ]
                  , 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?" ]
              , 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 " "
-          , 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)
                   ]
           ]
@@ -161,6 +178,7 @@ nnote st' =
       Etitle e -> _ { title = e }
       Etext e -> _ { text = e }
       EisMarkdown e -> _ { isMarkdown = e }
+      Eshared e -> _ { shared = e }
 
   -- | Delete
   handleAction (NDeleteAsk e) = do

purs/src/Model.purs

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

src/Application.hs

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

src/Handler/Notes.hs

@@ -11,6 +11,7 @@ import qualified Text.Blaze.Html5 as H
 
 getNotesR :: UserNameP -> Handler Html
 getNotesR unamep@(UserNameP uname) = do
+  muserid <- maybeAuthId
   (limit', page') <- lookupPagingParams
   let queryp = "query" :: Text
   mquery <- lookupGetParam queryp
@@ -19,7 +20,8 @@ getNotesR unamep@(UserNameP uname) = do
       mqueryp = fmap (\q -> (queryp, q)) mquery
   (bcount, notes) <- runDB $ do
     Entity userId _ <- getBy404 (UniqueUserName uname)
-    getNoteList userId mquery limit page
+    let sharedp = if muserid == Just userId then SharedAll else SharedPublic
+    getNoteList userId mquery sharedp limit page
   req <- getRequest
   mroute <- getCurrentRoute
   defaultLayout $ do
@@ -58,7 +60,7 @@ getAddNoteViewR :: UserNameP -> Handler Html
 getAddNoteViewR unamep@(UserNameP uname) = do
   userId <- requireAuthId
   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
     $(widgetFile "note")
     toWidgetBody [julius|
@@ -107,6 +109,7 @@ data NoteForm = NoteForm
   , _title :: Maybe Text
   , _text :: Maybe Textarea
   , _isMarkdown :: Maybe Bool
+  , _shared :: Maybe Bool
   , _created :: Maybe UTCTimeStr
   , _updated :: Maybe UTCTimeStr
   } deriving (Show, Eq, Read, Generic)
@@ -129,6 +132,7 @@ _toNote userId NoteForm {..} = do
       (fromMaybe "" _title)
       (maybe "" unTextarea _text)
       (fromMaybe False _isMarkdown)
+      (fromMaybe False _shared)
       (fromMaybe time (fmap unUTCTimeStr _created))
       (fromMaybe time (fmap unUTCTimeStr _updated))
 
@@ -150,7 +154,7 @@ getNotesFeedR unamep@(UserNameP uname) = do
       page  = maybe 1   fromIntegral page'
   (bcount, notes) <- runDB $ do
       Entity userId _ <- getBy404 (UniqueUserName uname)
-      getNoteList userId mquery limit page
+      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

src/Model.hs

@@ -26,7 +26,7 @@ import qualified Data.Map.Strict as MS
 
 import ModelCustom
 
-share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase| 
+share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase|
 User json
   Id Int64
   name Text
@@ -72,6 +72,7 @@ Note json
   title Text
   text Text
   isMarkdown Bool
+  shared Bool default=False
   created UTCTime
   updated UTCTime
   deriving Show Eq Typeable Ord
@@ -151,7 +152,7 @@ authenticatePassword username password = do
       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] []
@@ -187,7 +188,7 @@ bookmarksQuery userId sharedp filterp tags mquery limit' page =
                 expr &&. (exists $   -- each tag becomes an exists constraint
                           from $ \t ->
                           where_ (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId &&.
-                                 (t ^. BookmarkTagTag `E.like` val tag)))) 
+                                 (t ^. BookmarkTagTag `E.like` val tag))))
           (b ^. BookmarkUserId E.==. val userId)
           tags
       case sharedp of
@@ -242,7 +243,7 @@ parseSearchQuery toExpr =
         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 /= '|') 
+        simpleTerm = P.takeWhile1 (\c -> not (isSpace c) && c /= ':' && c /= '|')
 
 parseTimeText :: (TI.ParseTime t, Monad m, Alternative m) => Text -> m t
 parseTimeText t =
@@ -267,13 +268,13 @@ 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 -> Limit -> Page -> DB (Int, [Entity Note])
-getNoteList key mquery limit' page =
+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 $
@@ -292,6 +293,10 @@ getNoteList key mquery limit' page =
       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)
@@ -415,6 +420,7 @@ fileNoteToNote user (FileNote {..} ) = do
       fileNoteTitle
       fileNoteText
       False
+      False
       fileNoteCreatedAt
       fileNoteUpdatedAt
 
@@ -425,19 +431,19 @@ insertDirFileNotes userId noteDirectory = do
       Left e -> print e
       Right fnotes -> do
         notes <- liftIO $ mapM (fileNoteToNote userId) fnotes
-        void $ mapM insertUnique notes 
+        void $ mapM insertUnique 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) 
+      noteBSS <- mapM (readFile . (fdir </>)) files
+      pure (mapM (A.eitherDecode' . fromStrict) noteBSS)
 
 -- AccountSettingsForm
 data AccountSettingsForm = AccountSettingsForm
-  { _privateDefault :: Bool 
-  , _archiveDefault :: Bool 
-  , _privacyLock :: Bool 
+  { _privateDefault :: Bool
+  , _archiveDefault :: Bool
+  , _privacyLock :: Bool
   } deriving (Show, Eq, Read, Generic)
 
 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
 
 gDefaultFormOptions :: A.Options
-gDefaultFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 } 
+gDefaultFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 }
 
 toBookmarkFormList :: [Entity Bookmark] -> [Entity BookmarkTag] -> [BookmarkForm]
 toBookmarkFormList bs as = do
@@ -533,7 +539,7 @@ upsertBookmark:: Maybe (Key Bookmark) -> Bookmark -> [Text] -> DB (UpsertResult,
 upsertBookmark mbid bm tags = do
   res <- case mbid of
     Just bid -> do
-      get bid >>= \case 
+      get bid >>= \case
         Just prev_bm -> replaceBookmark bid prev_bm
         _ -> fail "not found"
     Nothing -> do
@@ -542,7 +548,7 @@ upsertBookmark mbid bm tags = do
         _ -> (Created,) <$> insert bm
   insertTags (bookmarkUserId bm) (snd res)
   pure res
-  where 
+  where
     prepareReplace prev_bm = do
       if (bookmarkHref bm /= bookmarkHref prev_bm)
         then bm { bookmarkArchiveHref = Nothing }
@@ -567,7 +573,7 @@ upsertNote:: Maybe (Key Note) -> Note -> DB (UpsertResult, Key Note)
 upsertNote mnid bmark@Note{..} = do
   case mnid of
     Just nid -> do
-      get nid >>= \case 
+      get nid >>= \case
         Just _ -> do
           replace nid bmark
           pure (Updated, nid)