{-# LANGUAGE OverloadedStrings, LambdaCase, TupleSections #-}

-- |
-- Module      :  Text.Gemini.Web
-- Copyright   :  (c) Sena, 2024
-- License     :  AGPL-3.0-or-later
--
-- Maintainer  :  Sena <jn-sena@proton.me>
-- Stability   :  stable
-- Portability :  portable
--
-- A tiny Gemtext to HTML converter for gemmula.
--
-- Encodes parsed Gemtext documents and lines as HTML 'Text'.

module Text.Gemini.Web
    ( -- * Encoding documents
      encode
      -- * Encoding single items
    , prettyItem
    , encodeItem
      -- * Rewriting links
    , rewriteLink
    , webifyLink
      -- * Other
    , getTitle
    ) where

import Control.Exception (catch, SomeException)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (fromMaybe, fromJust, isNothing, maybeToList)
import Data.Either (isRight)
import Data.List (find)
import Data.Bool (bool)
import qualified Text.URI as URI
import Network.HTTP (simpleHTTP, getRequest, getResponseCode)

import Text.Gemini (GemDocument, GemItem (..))


-- | Encode parsed 'GemDocument' as a HTML file.
-- The output 'Text' uses LF-endings. Uses the 'prettyItem' function below.
--
-- Valid HTML characters are escaped before encoding.
--
-- Empty 'GemList's are ignored and empty 'GemText's are replaced with @<br />@.
encode :: GemDocument -> Text
encode :: GemDocument -> Text
encode = [Text] -> Text
T.unlines ([Text] -> Text) -> (GemDocument -> [Text]) -> GemDocument -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GemItem -> Text) -> GemDocument -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map GemItem -> Text
prettyItem (GemDocument -> [Text])
-> (GemDocument -> GemDocument) -> GemDocument -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GemItem -> Bool) -> GemDocument -> GemDocument
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (GemItem -> Bool) -> GemItem -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GemItem -> Bool
empty)
    where empty :: GemItem -> Bool
          empty :: GemItem -> Bool
empty (GemList [Text]
list) = [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
list
          empty GemItem
_ = Bool
False


-- | Encode a /single/ parsed 'GemItem' as HTML text.
-- The output 'Text' uses LF-endings and might be multiple lines.
--
-- Valid HTML characters are escaped before encoding.
--
-- Unlike 'encodeItem', long lines (> 80) will be split to multiple lines to
-- make it look prettier. Empty 'GemText's are also replaced with @<br />@.
--
-- Links have a "scheme" attribute set to "gemini" if the scheme of the URI
-- is @gemini://@, to make them stylable with CSS.
--
-- /Beware/ that the output text doesn't end with a newline.
prettyItem :: GemItem -> Text
prettyItem :: GemItem -> Text
prettyItem (GemText Text
line) = Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool (Text -> [(Text, Text)] -> Text -> Text
tag Text
"p" [] (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
multiline Text
line) Text
"<br />" (Text -> Bool
T.null (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text
line)
prettyItem (GemLink Text
link Maybe Text
desc) =
     let s :: Text
s = Text -> (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"http" RText 'Scheme -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText (Maybe (RText 'Scheme) -> Text) -> Maybe (RText 'Scheme) -> Text
forall a b. (a -> b) -> a -> b
$ URI -> Maybe (RText 'Scheme)
URI.uriScheme (URI -> Maybe (RText 'Scheme)) -> URI -> Maybe (RText 'Scheme)
forall a b. (a -> b) -> a -> b
$ URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe URI
URI.emptyURI (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ Text -> Maybe URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI Text
link
      in Text -> [(Text, Text)] -> Text -> Text
tag Text
"a" ([(Text
"href", Text
link)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Text)] -> [(Text, Text)] -> Bool -> [(Text, Text)]
forall a. a -> a -> Bool -> a
bool [] [(Text
"scheme", Text
s)] (Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"gemini")) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
multiline (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
link Maybe Text
desc
prettyItem (GemHeading Int
level Text
text) = Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [(Text, Text)] -> Text -> Text
tag (Text
"h" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
level Int
6)) [] (Text -> Text
multiline Text
text)
prettyItem (GemList [Text]
list) = Text
"<ul>\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [(Text, Text)] -> Text -> Text
tag Text
"li" []) [Text]
list) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</ul>"
prettyItem (GemQuote Text
text) = Text -> [(Text, Text)] -> Text -> Text
tag Text
"blockquote" [] (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
multiline Text
text
prettyItem (GemPre [Text]
text Maybe Text
alt) = Text -> [(Text, Text)] -> Text -> Text
tag Text
"pre" (Maybe (Text, Text) -> [(Text, Text)]
forall a. Maybe a -> [a]
maybeToList (Maybe (Text, Text) -> [(Text, Text)])
-> Maybe (Text, Text) -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ (Text
"title",) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
alt) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines [Text]
text

-- | Encode a /single/ parsed 'GemItem' as HTML text.
-- The output 'Text' uses LF-endings and might be multiple lines.
--
-- Valid HTML characters are escaped before encoding.
--
-- /Beware/ that the output text doesn't end with a newline.
encodeItem :: GemItem -> Text
encodeItem :: GemItem -> Text
encodeItem (GemText Text
line) = Text -> [(Text, Text)] -> Text -> Text
tag Text
"p" [] Text
line
encodeItem (GemLink Text
link Maybe Text
desc) = Text -> [(Text, Text)] -> Text -> Text
tag Text
"a" [(Text
"href", Text
link)] (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
link Maybe Text
desc
encodeItem (GemHeading Int
level Text
text) = Text -> [(Text, Text)] -> Text -> Text
tag (Text
"h" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
level Int
6)) [] Text
text
encodeItem (GemList [Text]
list) = Text
"<ul>\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [(Text, Text)] -> Text -> Text
tag Text
"li" []) [Text]
list) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</ul>"
encodeItem (GemQuote Text
text) = Text -> [(Text, Text)] -> Text -> Text
tag Text
"blockquote" [] Text
text
encodeItem (GemPre [Text]
text Maybe Text
alt) = Text -> [(Text, Text)] -> Text -> Text
tag Text
"pre" (Maybe (Text, Text) -> [(Text, Text)]
forall a. Maybe a -> [a]
maybeToList (Maybe (Text, Text) -> [(Text, Text)])
-> Maybe (Text, Text) -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ (Text
"title",) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
alt) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines [Text]
text


-- | Rewrite @.gmi@ links as @.html@ links.
--
-- /Beware/ that this only applies to local 'GemLink's.
-- For rewriting non-local links as @http@, see 'webifyLink'.
rewriteLink :: GemItem -> GemItem
rewriteLink :: GemItem -> GemItem
rewriteLink (GemLink Text
link Maybe Text
desc)
    | Maybe (Bool, NonEmpty (RText 'PathPiece)) -> Bool
forall a. Maybe a -> Bool
isNothing (URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath URI
uri) Bool -> Bool -> Bool
|| Either Bool Authority -> Bool
forall a b. Either a b -> Bool
isRight (URI -> Either Bool Authority
URI.uriAuthority URI
uri) = Text -> Maybe Text -> GemItem
GemLink Text
link Maybe Text
desc
    | Bool
otherwise = Text -> Maybe Text -> GemItem
GemLink (Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
link (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".html") (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripSuffix Text
".gmi" Text
link) Maybe Text
desc
    where uri :: URI
uri = URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe URI
URI.emptyURI (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ Text -> Maybe URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI Text
link
rewriteLink GemItem
item = GemItem
item

-- | Rewrite @gemini://@ link as @http://@ if it can be reached over HTTP.
--
-- This is only useful if the specified link has a proxied mirror (like @geminiprotocol.net@).
--
-- Does /nothing/ if the link is local or can't be reached.
webifyLink :: GemItem -> IO GemItem
webifyLink :: GemItem -> IO GemItem
webifyLink (GemLink Text
link Maybe Text
desc)
    | Either Bool Authority -> Bool
forall a b. Either a b -> Bool
isRight (URI -> Either Bool Authority
URI.uriAuthority URI
uri) Bool -> Bool -> Bool
&& Text -> (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" RText 'Scheme -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText (URI -> Maybe (RText 'Scheme)
URI.uriScheme URI
uri) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"gemini" =
          (\(Int
t, Int
_, Int
_) -> Text -> Maybe Text -> GemItem
GemLink (Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool (URI -> Text
URI.render URI
uri') Text
link (Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3)) Maybe Text
desc) ((Int, Int, Int) -> GemItem) -> IO (Int, Int, Int) -> IO GemItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              IO (Int, Int, Int)
-> (SomeException -> IO (Int, Int, Int)) -> IO (Int, Int, Int)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Request String -> IO (Result (Response String))
forall ty. HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP (String -> Request String
getRequest (String -> Request String) -> String -> Request String
forall a b. (a -> b) -> a -> b
$ URI -> String
URI.renderStr URI
uri') IO (Result (Response String))
-> (Result (Response String) -> IO (Int, Int, Int))
-> IO (Int, Int, Int)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result (Response String) -> IO (Int, Int, Int)
forall ty. Result (Response ty) -> IO (Int, Int, Int)
getResponseCode)
                  (\SomeException
e -> let SomeException
_ = (SomeException
e :: SomeException) in (Int, Int, Int) -> IO (Int, Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
9, Int
9, Int
9))
    | Bool
otherwise = GemItem -> IO GemItem
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GemItem -> IO GemItem) -> GemItem -> IO GemItem
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> GemItem
GemLink Text
link Maybe Text
desc
    where uri :: URI
uri = URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe URI
URI.emptyURI (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ Text -> Maybe URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI Text
link
          uri' :: URI
uri' = URI
uri {URI.uriScheme = Just (fromJust $ URI.mkScheme "http")}
webifyLink GemItem
item = GemItem -> IO GemItem
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GemItem
item


-- | Get the text of the first @<h1>@ in the document, if there's any.
--
-- Useful for using as @<title>@.
getTitle :: GemDocument -> Maybe Text
getTitle :: GemDocument -> Maybe Text
getTitle GemDocument
doc = (\case { GemHeading Int
_ Text
t -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t; GemItem
_ -> Maybe Text
forall a. Maybe a
Nothing })
                   (GemItem -> Maybe Text) -> Maybe GemItem -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (GemItem -> Bool) -> GemDocument -> Maybe GemItem
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\case { GemHeading Int
l Text
_ -> Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1; GemItem
_ -> Bool
False }) GemDocument
doc

-- Creates a HTML tag with the given name, attributes and body.
-- The body and attributes are escaped using the functions below.
tag :: Text -> [(Text, Text)] -> Text -> Text
tag :: Text -> [(Text, Text)] -> Text -> Text
tag Text
name [(Text, Text)]
attrs Text
body = Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
attr [(Text, Text)]
attrs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeBody Text
body Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"
    where attr :: (Text, Text) -> Text
          attr :: (Text, Text) -> Text
attr (Text
n, Text
v) = Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ((Text -> Text) -> (Text -> Text) -> Bool -> Text -> Text
forall a. a -> a -> Bool -> a
bool Text -> Text
escapeAttr Text -> Text
escapeHref (Bool -> Text -> Text) -> Bool -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"href") Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""

-- Split the text to multiple lines if the text is longer than 80 characters.
-- Indents the text by 2 spaces for every line then.
multiline :: Text -> Text
multiline :: Text -> Text
multiline Text
text = let result :: [Text]
result = [Text] -> [Text] -> [Text] -> [Text]
split [] [] ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
text
                  in Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool ([Text] -> Text
T.concat [Text]
result) (Text
"\n  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n  " [Text]
result Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n") ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
result Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
    where split :: [Text] -> [Text] -> [Text] -> [Text]
          split :: [Text] -> [Text] -> [Text] -> [Text]
split [Text]
line [Text]
ls (Text
w:[Text]
ws)
              | Text -> Int
T.length ([Text] -> Text
T.unwords [Text]
line) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
80 = [Text] -> [Text] -> [Text] -> [Text]
split ([Text]
line [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
w]) [Text]
ls [Text]
ws
              | Bool
otherwise = [Text] -> [Text] -> [Text] -> [Text]
split [Text
w] ([Text]
ls [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [[Text] -> Text
T.unwords [Text]
line]) [Text]
ws
          split [Text]
line [Text]
ls [] = [Text]
ls [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [[Text] -> Text
T.unwords [Text]
line]


-- Escape the relevant characters inside bodies such as ampersands and tag delimiters.
escapeBody :: Text -> Text
escapeBody :: Text -> Text
escapeBody = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
">" Text
"&gt;" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"<" Text
"&lt;" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"&" Text
"&amp;"

-- Escape the relevant characters inside attributes such as ampersands and quotes.
escapeAttr :: Text -> Text
escapeAttr :: Text -> Text
escapeAttr = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"'" Text
"&#39;" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\"" Text
"&quot;" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"&" Text
"&amp;"

-- Escape the relevant characters inside links attributes such as quotes.
escapeHref :: Text -> Text
escapeHref :: Text -> Text
escapeHref = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"'" Text
"%27"(Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\"" Text
"%22"