insert note via post

app/Css.hs

@@ -0,0 +1,92 @@
+module Css where
+
+import Data.Text qualified as T
+import Text.RawString.QQ
+
+css :: T.Text
+css = [r|
+body {
+  margin: 40px auto;
+  max-width: 650px;
+  line-height: 1.6;
+  font-size: 18px;
+  color: #e2d2bf;
+  background-color: #0f0f15;
+  padding: 0 10px;
+}
+
+a { color: #f79226; }
+a:hover { color: #ffcd56; }
+
+.user-details {
+  display: flex;
+  background-color: #081829;
+  color: #e2d2bf;
+  border: 1px solid #fecb87;
+}
+.user-details a { color: #ffa95e; }
+.user-details a:hover { color: #ffcd56; }
+
+.user-details * {
+  margin: 10px;
+}
+
+.user-details-details * {
+  margin: 0px;
+}
+
+footer {
+  margin-top: 50px;
+  margin-bottom: 20px;
+  border-top: 1px solid #fecb87;
+}
+
+.note-header {
+  border-top: 1px solid #888;
+  margin-top: 20px;
+  padding-top: 20px;
+  text-align: center;
+}
+
+.avatar {
+  width: 100px;
+  height: 100px;
+  border-radius: 10px;
+  border: 1px solid #fecb87;
+  margin: 0px;
+}
+
+img {
+  max-width: 100%;
+  display: block;
+}
+
+h1,h2,h3 {
+  line-height:1.2
+}
+dd {
+  margin-right: 12px;
+  margin-left: 12px;
+  margin-bottom: 20px;
+}
+.ltr { direction: ltr }
+.rtl { direction: rtl }
+
+.new-note-div { width: 90%; margin: 5px auto; auto; border-radius: 5px;
+}
+.new-note { width: 100%; margin: auto;
+  margin-top: 30px;
+  padding-top: 20px;
+  border-top: 1px solid #888;
+}
+.new-note-text { width: 100%; border-radius: 5px; border: 1px solid #fecb87;
+  background-color: #081829;
+  color: white;
+  padding: 5px;
+}
+.new-note-content { width: 100%; min-width: 100%; max-width: 100%; height: 100px; border-radius: 5px; border: 1px solid #fecb87;
+  padding: 5px;
+  background-color: #081829;
+  color: white;
+}
+|]

app/DB.hs

@@ -13,7 +13,7 @@ import Fedi
 data DB
   = DB
     { getNotes :: IO [Note]
-    , insertNote :: NoteEntry -> IO ()
+    , insertNote :: NoteEntry -> IO NoteId
     }
 
 -- * Data types
@@ -84,10 +84,10 @@ getNotesFromDb :: Url -> DB.SQLite [Note]
 getNotesFromDb url =
   map decodeNoteRow <$> uncurry DB.runWith (getNotesSQL url)
 
-insertNoteToDb :: Url -> NoteEntry -> DB.SQLite ()
+insertNoteToDb :: Url -> NoteEntry -> DB.SQLite NoteId
 insertNoteToDb actor note = do
-  _ <- uncurry DB.runWith (insertNoteSQL actor note)
-  pure ()
+  [n] <- map decodeNoteIdRow <$> uncurry DB.runWith (insertNoteSQL actor note)
+  pure n
 
 -- ** SQL
 
@@ -113,6 +113,7 @@ insertNoteSQL actor note =
   ( [r|
       INSERT INTO note(actor, inReplyTo, content, name, url)
       VALUES (?, ?, ?, ?, ?)
+      RETURNING cast(id as text)
     |]
   , [ DB.SQLText (T.pack actor)
     , toNullableString note.inReplyTo
@@ -153,6 +154,11 @@ decodeNoteRow = \case
         }
   row -> error $ "Couldn't decode row as Note: " <> show row
 
+decodeNoteIdRow :: [DB.SQLData] -> NoteId
+decodeNoteIdRow = \case
+  [ DB.SQLText noteid] -> T.unpack noteid
+  row -> error $ "Couldn't decode row as NoteId: " <> show row
+
 nullableString :: DB.SQLData -> Maybe (Maybe String)
 nullableString = \case
   DB.SQLText text -> Just (Just $ T.unpack text)

app/Html.hs

@@ -4,14 +4,21 @@ import Data.String (fromString)
 import Data.Char (ord, isAlpha)
 import Data.Text qualified as T
 import Lucid qualified as H
-import Text.RawString.QQ
 
 import Fedi qualified as Fedi
+import Css (css)
 
 -- * HTML
 
 type Html = H.Html ()
 
+adminPage :: Fedi.UserDetails -> [Fedi.Note] -> Html
+adminPage details notes =
+  template (T.pack $ Fedi.fullmention details) do
+  userHtml details
+  newNoteHtml details
+  notesHtml notes
+
 actorPage :: Fedi.UserDetails -> [Fedi.Note] -> Html
 actorPage details notes =
   template (T.pack $ Fedi.fullmention details) do
@@ -52,6 +59,16 @@ noteHtml :: Fedi.Note -> Html
 noteHtml note = do
   H.div_ [ H.class_ "note" ] $ do
     H.div_ [ H.class_ "note-header" ] $ do
+      case note.name of
+        Just title ->
+          H.h2_ [ H.class_ (checkDirection $ T.pack title) ] (fromString title)
+        Nothing -> pure ()
+
+      case note.url of
+        Just url ->
+          H.p_ $ H.a_ [ H.href_ (T.pack url) ] $ fromString url
+        Nothing -> pure ()
+
       H.a_
         [ H.href_ (T.pack note.id)
         , H.class_ "note-time"
@@ -69,74 +86,40 @@ checkDirection txt =
     Just (c, _) | ord 'א' <= ord c && ord c <= ord 'ת' -> "rtl"
     _ -> "ltr"
 
--- * CSS
+-- | A new post form.
+newNoteHtml :: Fedi.UserDetails -> Html
+newNoteHtml details = do
+  H.form_
+    [ H.method_ "post"
+    , H.action_ ("/" <> T.pack details.username <> "/admin/new")
+    , H.class_ "new-note"
+    ]
+    ( do
+      H.div_ [ H.class_ "new-note-div" ] $ H.input_
+        [ H.class_ "new-note-text"
+        , H.autofocus_
+        , H.type_ "text"
+        , H.name_ "title"
+        , H.placeholder_ "A title (optional)"
+        ]
 
-css :: T.Text
-css = [r|
-body {
-  margin: 40px auto;
-  max-width: 650px;
-  line-height: 1.6;
-  font-size: 18px;
-  color: #e2d2bf;
-  background-color: #0f0f15;
-  padding: 0 10px;
-}
+      H.div_ [ H.class_ "new-note-div" ] $ H.textarea_
+        [ H.class_ "new-note-content"
+        , H.name_ "content"
+        , H.placeholder_ "Yes?"
+        ] ""
 
-a { color: #f79226; }
-a:hover { color: #ffcd56; }
+      H.div_ [ H.class_ "new-note-div" ] $ H.input_
+        [ H.class_ "new-note-text"
+        , H.type_ "url"
+        , H.name_ "url"
+        , H.placeholder_ "A URL this note should link to (optional)"
+        ]
 
-.user-details {
-  display: flex;
-  background-color: #081829;
-  color: #e2d2bf;
-  border: 1px solid #fecb87;
-}
-.user-details a { color: #ffa95e; }
-.user-details a:hover { color: #ffcd56; }
-
-.user-details * {
-  margin: 10px;
-}
-
-.user-details-details * {
-  margin: 0px;
-}
-
-footer {
-  margin-top: 50px;
-  margin-bottom: 20px;
-  border-top: 1px solid #fecb87;
-}
-
-.note-header {
-  border-top: 1px solid #888;
-  margin-top: 20px;
-  padding-top: 20px;
-  text-align: center;
-}
-
-.avatar {
-  width: 100px;
-  height: 100px;
-  border-radius: 10px;
-  border: 1px solid #fecb87;
-  margin: 0px;
-}
-
-img {
-  max-width: 100%;
-  display: block;
-}
-
-h1,h2,h3 {
-  line-height:1.2
-}
-dd {
-  margin-right: 12px;
-  margin-left: 12px;
-  margin-bottom: 20px;
-}
-.ltr { direction: ltr }
-.rtl { direction: rtl }
-|]
+      H.div_ [ H.class_ "new-note-div" ] $ H.input_
+        [ H.class_ "new-note-submit"
+        , H.type_ "submit"
+        , H.title_ "Add a new note"
+        , H.value_ "Post"
+        ]
+    )

app/Main.hs

@@ -5,6 +5,7 @@ import Data.String (fromString)
 import Database.Sqlite.Easy qualified as Sqlite
 import Data.Aeson qualified as A
 import Network.Wai.Handler.Warp (run, Port)
+import Network.Wai.Middleware.Routed qualified as Wai
 import Network.Wai.Middleware.HttpAuth (basicAuth)
 import Network.Wai.Middleware.RequestLogger qualified as Logger
 import System.Environment (getArgs)
@@ -52,13 +53,16 @@ insertNoteFromFile file = do
 
   db <- mkDB connStr details
 
-  db.insertNote NoteEntry
+  note <- db.insertNote NoteEntry
     { content = content
     , inReplyTo = Nothing
     , name = Nothing
     , url = Nothing
     }
 
+  putStrLn "Inserted."
+  print note
+
 
 serve :: IO ()
 serve = do
@@ -95,19 +99,23 @@ usageError =
     , " - FEDI_PORT=<PORT>"
     , " - FEDI_DETAILS=<FILE>"
     , " - FEDI_CONN_STRING=<SQLITE_CONN_STR>"
-    , " - FEDI_CONN_STRING=<SQLITE_CONN_STR>"
     , " - FEDI_AUTH=<user>,<password>"
     ]
 
 -- | Run server at at specific port.
 runServer :: Port -> Twain.Middleware -> Twain.Application -> IO ()
-runServer port _authMiddleware app = do
+runServer port authMiddleware app = do
   putStrLn $ unwords
     [ "Running fedi at"
     , "http://localhost:" <> show port
     , "(ctrl-c to quit)"
     ]
-  run port (Logger.logStdoutDev app)
+  auth <- Wai.routedMiddleware matchAdmin <$> pure authMiddleware
+  run port (Logger.logStdoutDev $ auth app)
+
+
+matchAdmin :: [T.Text] -> Bool
+matchAdmin = any (=="admin")
 
 -- | Application description.
 mkFediApp :: Sqlite.ConnectionString -> IO Twain.Application
@@ -181,8 +189,34 @@ routes db detailsFile =
     Twain.get Fedi.matchWebfinger do
     details <- liftIO $ fetchUserDetails detailsFile
     Fedi.handleWebfinger details
+
+  , -- Admin page
+    Twain.get (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin") do
+      details <- liftIO $ fetchUserDetails detailsFile
+      notes <- liftIO db.getNotes
+      Twain.send $ Twain.html $ H.renderBS $ adminPage details notes
+
+  , -- New post
+    Twain.post (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin/new") do
+      title <- Twain.param "title"
+      content <- Twain.param "content"
+      url <- Twain.param "url"
+      details <- liftIO $ fetchUserDetails detailsFile
+
+      noteid <-
+        liftIO $ db.insertNote NoteEntry
+          { content = content
+          , inReplyTo = Nothing
+          , name = if trim title == "" then Nothing else Just title
+          , url = if trim url == "" then Nothing else Just url
+          }
+
+      Twain.send $ Twain.redirect302 (fromString ("/" <> details.username <> "/notes/" <> noteid))
   ]
 
+trim :: String -> String
+trim = unwords . words
+
 fetchUserDetails :: FilePath -> IO Fedi.UserDetails
 fetchUserDetails detailsFile =
   A.eitherDecodeFileStrict detailsFile

fedi.cabal

@@ -61,6 +61,7 @@ executable fedi
   other-modules:
     DB
     Html
+    Css
   -- other-extensions:
   build-depends:
       aeson

src/Fedi/Activity.hs

@@ -12,6 +12,7 @@ data Activity
     , actor :: ActorId
     , object :: Object
     }
+  deriving Show
 
 activityUrl :: Activity -> ActivityUrl
 activityUrl = \case
@@ -21,6 +22,7 @@ type ActivityUrl = Url
 
 data Object
   = NoteObject Note
+  deriving Show
 
 objectUrl :: Object -> Url
 objectUrl = \case
@@ -37,6 +39,7 @@ data Note
     , url :: Maybe Url
     , replies :: Collection Unordered Note
     }
+  deriving Show
 
 type NoteId = Url
 
@@ -56,6 +59,7 @@ data OrderedCollectionPage a
     , partOf :: Url
     , orderedItems :: [a]
     }
+  deriving Show
 
 data Collection order a
   = Collection
@@ -65,6 +69,7 @@ data Collection order a
     , first :: Maybe Url
     , last :: Maybe Url
     }
+  deriving Show
 
 instance A.ToJSON Note where
   toJSON note =

src/Fedi/Types.hs

@@ -38,7 +38,7 @@ data UserDetails
     , publicPem :: Pem
     , privatePem :: FilePath
     }
-  deriving (Generic, A.FromJSON)
+  deriving (Show, Generic, A.FromJSON)
 
 actorUrl :: UserDetails -> Url
 actorUrl details =