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