From 76335812d33070fa1f1c0adc16e277456ed7f695 Mon Sep 17 00:00:00 2001 From: me Date: Tue, 17 Dec 2024 10:46:59 +0200 Subject: [PATCH] insert note via post --- app/Css.hs | 92 ++++++++++++++++++++++++++++++++ app/DB.hs | 14 +++-- app/Html.hs | 121 +++++++++++++++++++------------------------ app/Main.hs | 42 +++++++++++++-- fedi.cabal | 1 + src/Fedi/Activity.hs | 5 ++ src/Fedi/Types.hs | 2 +- 7 files changed, 199 insertions(+), 78 deletions(-) create mode 100644 app/Css.hs diff --git a/app/Css.hs b/app/Css.hs new file mode 100644 index 0000000..2e275cd --- /dev/null +++ b/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; +} +|] diff --git a/app/DB.hs b/app/DB.hs index 2779435..e915ac0 100644 --- a/app/DB.hs +++ b/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) diff --git a/app/Html.hs b/app/Html.hs index d94439a..2789832 100644 --- a/app/Html.hs +++ b/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" + ] + ) diff --git a/app/Main.hs b/app/Main.hs index c58bf11..c3afc49 100644 --- a/app/Main.hs +++ b/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=" , " - FEDI_DETAILS=" , " - FEDI_CONN_STRING=" - , " - FEDI_CONN_STRING=" , " - FEDI_AUTH=," ] -- | 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 diff --git a/fedi.cabal b/fedi.cabal index d8ea882..3cee6d6 100644 --- a/fedi.cabal +++ b/fedi.cabal @@ -61,6 +61,7 @@ executable fedi other-modules: DB Html + Css -- other-extensions: build-depends: aeson diff --git a/src/Fedi/Activity.hs b/src/Fedi/Activity.hs index 12efa66..fc5a8ed 100644 --- a/src/Fedi/Activity.hs +++ b/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 = diff --git a/src/Fedi/Types.hs b/src/Fedi/Types.hs index 6d73af4..c77ae79 100644 --- a/src/Fedi/Types.hs +++ b/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 =