From 459a7f58e4073804011ffd92aedf8061967a2b27 Mon Sep 17 00:00:00 2001 From: me Date: Tue, 17 Dec 2024 10:46:59 +0200 Subject: [PATCH] html pages --- app/Html.hs | 142 +++++++++++++++++++++++++++++++++++++++++++++ app/Main.hs | 44 +++++++++++--- fedi.cabal | 2 + src/Fedi/Routes.hs | 8 +-- src/Fedi/Types.hs | 3 + 5 files changed, 185 insertions(+), 14 deletions(-) create mode 100644 app/Html.hs diff --git a/app/Html.hs b/app/Html.hs new file mode 100644 index 0000000..d94439a --- /dev/null +++ b/app/Html.hs @@ -0,0 +1,142 @@ +module Html where + +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 + +-- * HTML + +type Html = H.Html () + +actorPage :: Fedi.UserDetails -> [Fedi.Note] -> Html +actorPage details notes = + template (T.pack $ Fedi.fullmention details) do + userHtml details + notesHtml notes + +-- | HTML boilerplate template +template :: T.Text -> Html -> Html +template title content = + H.doctypehtml_ $ do + H.head_ $ do + H.meta_ [ H.charset_ "utf-8" ] + H.meta_ [ H.name_ "viewport", H.content_ "width=device-width initial_scale=1.0" ] + H.title_ (H.toHtml $ "Fediserve - " <> title) + H.style_ css + H.body_ $ do + H.div_ [ H.class_ "main" ] $ do + content + H.footer_ "" + +userHtml :: Fedi.UserDetails -> Html +userHtml details = do + H.div_ [ H.class_ "user-details" ] do + H.a_ [ H.href_ (T.pack $ "/" <> details.username) ] $ + H.img_ [ H.class_ "avatar", H.src_ (T.pack details.icon) ] + H.div_ [ H.class_ "user-details-details" ] do + H.h2_ (fromString details.username) + H.a_ [ H.href_ (T.pack $ Fedi.actorUrl details) ] $ + H.p_ (fromString $ Fedi.fullmention details) + H.p_ (fromString details.summary) + +notesHtml :: [Fedi.Note] -> Html +notesHtml notes = do + H.div_ [ H.class_ "notes" ] $ mapM_ noteHtml notes + +-- | A single post as HTML. +noteHtml :: Fedi.Note -> Html +noteHtml note = do + H.div_ [ H.class_ "note" ] $ do + H.div_ [ H.class_ "note-header" ] $ do + H.a_ + [ H.href_ (T.pack note.id) + , H.class_ "note-time" + , H.title_ "See note page" + ] + (H.toHtml (T.pack (show note.published))) + + H.div_ [H.class_ $ "note-content " <> checkDirection note.content] $ do + H.toHtmlRaw note.content + +checkDirection :: T.Text -> T.Text +checkDirection txt = + case T.uncons $ T.dropWhile (\c -> not (isAlpha c) && c /= '<') txt of + Just ('<', rest) -> checkDirection (T.dropWhile (/= '>') rest) + Just (c, _) | ord 'א' <= ord c && ord c <= ord 'ת' -> "rtl" + _ -> "ltr" + +-- * CSS + +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 } +|] diff --git a/app/Main.hs b/app/Main.hs index 886c329..c58bf11 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -17,7 +17,9 @@ import qualified Data.Text.IO as T import qualified Data.Text as T import System.IO.Unsafe (unsafePerformIO) import Control.Monad.IO.Class (liftIO) +import Lucid qualified as H +import Html import DB data Command @@ -39,7 +41,7 @@ main = do insertNoteFromFile :: FilePath -> IO () insertNoteFromFile file = do - connStr <- maybe "/tmp/jot_sqlite_db.sqlite" fromString <$> lookupEnv "FEDI_CONN_STRING" + connStr <- maybe "/tmp/fediserve_sqlite_db.sqlite" fromString <$> lookupEnv "FEDI_CONN_STRING" content <- T.readFile file detailsFile <- lookupEnv "FEDI_DETAILS" @@ -76,11 +78,11 @@ serve = do secureMemFromByteString u == username && secureMemFromByteString p == password ) - "My Jot" + "My Fediserve" Just{} -> usageError fediPort <- maybe 3001 read <$> lookupEnv "FEDI_PORT" - conn <- maybe "/tmp/jot_sqlite_db.sqlite" fromString <$> lookupEnv "FEDI_CONN_STRING" + conn <- maybe "/tmp/fediserve_sqlite_db.sqlite" fromString <$> lookupEnv "FEDI_CONN_STRING" putStrLn $ "and with connection string " <> show (Sqlite.unConnectionString conn) <> "." runServer fediPort authMiddleware =<< mkFediApp conn @@ -99,13 +101,13 @@ usageError = -- | 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 $ authMiddleware app) + run port (Logger.logStdoutDev app) -- | Application description. mkFediApp :: Sqlite.ConnectionString -> IO Twain.Application @@ -129,8 +131,15 @@ routes :: DB -> FilePath -> [Twain.Middleware] routes db detailsFile = [ -- Match actor Twain.get (Fedi.matchUser $ unsafePerformIO $ fetchUserDetails detailsFile) do - details <- liftIO $ fetchUserDetails detailsFile - Fedi.handleUser details + request <- Twain.request + if Fedi.checkContentTypeAccept request + then do + details <- liftIO $ fetchUserDetails detailsFile + Fedi.handleUser details + else do + details <- liftIO $ fetchUserDetails detailsFile + notes <- liftIO db.getNotes + Twain.send $ Twain.html $ H.renderBS $ actorPage details notes , -- Match outbox Twain.get (Fedi.matchOutbox $ unsafePerformIO $ fetchUserDetails detailsFile) do @@ -148,8 +157,25 @@ routes db detailsFile = , -- Match Note object Twain.get (Fedi.matchNote $ unsafePerformIO $ fetchUserDetails detailsFile) do details <- liftIO $ fetchUserDetails detailsFile - notes <- map noteToCreate <$> liftIO db.getNotes - Fedi.handleNote details notes + notes <- liftIO db.getNotes + + request <- Twain.request + if Fedi.checkContentTypeAccept request + then do + Fedi.handleNote details notes + else do + noteId <- Twain.param "note_id" + let + noteUrl = + "https://" + <> details.domain + <> "/" + <> details.username + <> "/notes/" + <> noteId + thenote = filter (\note -> note.id == noteUrl) notes + + Twain.send $ Twain.html $ H.renderBS $ actorPage details thenote , -- Match webfinger Twain.get Fedi.matchWebfinger do diff --git a/fedi.cabal b/fedi.cabal index ce8bd57..d8ea882 100644 --- a/fedi.cabal +++ b/fedi.cabal @@ -60,6 +60,7 @@ executable fedi main-is: Main.hs other-modules: DB + Html -- other-extensions: build-depends: aeson @@ -73,6 +74,7 @@ executable fedi , sqlite-easy , raw-strings-qq , securemem + , lucid2 hs-source-dirs: app default-language: GHC2021 diff --git a/src/Fedi/Routes.hs b/src/Fedi/Routes.hs index 2eb36ae..67c903e 100644 --- a/src/Fedi/Routes.hs +++ b/src/Fedi/Routes.hs @@ -11,7 +11,6 @@ import Fedi.Types import Fedi.Activity import Fedi.Actor import Fedi.Webfinger -import Data.Functor ((<&>)) -- * Routes @@ -66,11 +65,11 @@ handleCreate details items = do matchNote :: UserDetails -> Twain.PathPattern matchNote details = fromString ("/" <> details.username <> "/notes/:note_id") -handleNote :: UserDetails -> [Activity] -> Twain.ResponderM a +handleNote :: UserDetails -> [Note] -> Twain.ResponderM a handleNote details items = do noteId <- Twain.param "note_id" let - createUrl = + noteUrl = "https://" <> details.domain <> "/" @@ -79,8 +78,7 @@ handleNote details items = do <> noteId let content = - find (\create -> objectUrl (create.object) == createUrl) items - <&> \create -> create.object + find (\note -> note.id == noteUrl) items Twain.send $ jsonLD (A.encode content) -- * User diff --git a/src/Fedi/Types.hs b/src/Fedi/Types.hs index d303596..6d73af4 100644 --- a/src/Fedi/Types.hs +++ b/src/Fedi/Types.hs @@ -43,3 +43,6 @@ data UserDetails actorUrl :: UserDetails -> Url actorUrl details = "https://" <> details.domain <> "/" <> details.username + +fullmention :: UserDetails -> String +fullmention details = "@" <> details.username <> "@" <> details.domain