{-# LANGUAGE OverloadedStrings, LambdaCase, TupleSections #-}
module Text.Gemini.Web
(
encode
, prettyItem
, encodeItem
, rewriteLink
, webifyLink
, 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 :: 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
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
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
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
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
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
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
"\""
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]
escapeBody :: Text -> Text
escapeBody :: Text -> Text
escapeBody = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
">" Text
">" (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
"<" (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
"&"
escapeAttr :: Text -> Text
escapeAttr :: Text -> Text
escapeAttr = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"'" Text
"'" (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
""" (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
"&"
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"