html pages

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 }
+|]

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
+      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
+      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

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

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

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