125 lines
3.5 KiB
Haskell
125 lines
3.5 KiB
Haskell
module Html where
|
|
|
|
import Data.String (fromString)
|
|
import Data.Char (ord, isAlpha)
|
|
import Data.Text qualified as T
|
|
import Lucid qualified as H
|
|
|
|
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
|
|
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
|
|
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"
|
|
, 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"
|
|
|
|
-- | 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)"
|
|
]
|
|
|
|
H.div_ [ H.class_ "new-note-div" ] $ H.textarea_
|
|
[ H.class_ "new-note-content"
|
|
, H.name_ "content"
|
|
, H.placeholder_ "Yes?"
|
|
] ""
|
|
|
|
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)"
|
|
]
|
|
|
|
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"
|
|
]
|
|
)
|