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 =
+      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" ] $
-             [ 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_
-             , 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
   toTextarea input =
     S.split (Pattern "\n") input

purs/src/Component/NNote.purs

@@ -56,6 +56,7 @@ 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)) ]
+             , 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
@@ -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 " "
-          , input [ type_ InputReset , class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "cancel"
+            , 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"
                   , 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

@@ -15,26 +15,20 @@ module Application
   ) where
 
 import           Control.Monad.Logger (liftLoc, runLoggingT)
-import Database.Persist.Sqlite
+import           Database.Persist.Sqlite (createSqlitePool, runSqlPool, sqlDatabase, sqlPoolSize)
-       (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.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.Handler.Warp
+import           Network.Wai.Middleware.RequestLogger (Destination(Logger), IPAddrSource(..), OutputFormat(..), destination, mkRequestLogger, outputFormat)
-       (Settings, defaultSettings, defaultShouldDisplayException,
+import           System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
-        runSettings, setHost, setOnException, setPort, getPort)
+import           Yesod.Auth (getAuth)
-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 Network.Wai.Metrics as WM
@@ -74,9 +68,9 @@ makeFoundation appSettings = do
     createSqlitePool
       (sqlDatabase (appDatabaseConf appSettings))
       (sqlPoolSize (appDatabaseConf appSettings))
-  -- runLoggingT
+  runLoggingT
-  --   (runSqlPool runMigrations pool)
+    (runSqlPool runMigrations pool)
-  --   logFunc
+    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

@@ -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
@@ -272,8 +273,8 @@ 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 User -> Maybe Text -> SharedP -> Limit -> Page -> DB (Int, [Entity Note])
-getNoteList key mquery limit' page =
+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