MyLib.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}

module MyLib (someFunc) where

import Conduit (ConduitT, Flush (Chunk, Flush), Source, yield, (.|))
import Control.Concurrent (threadDelay)
import Control.Monad (forM_)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift)
import Data.ByteString.Builder (Builder)
import Data.Text (Text, pack)
import Data.XML.Types (Content (ContentText), Event (EventBeginDoctype, EventBeginElement, EventContent, EventEndDoctype, EventEndElement), Name)
import Network.HTTP.Types (status200)
import Network.Wai
import Network.Wai.Conduit
import Network.Wai.Handler.Warp (run)
import Text.XML.Stream.Render (def, renderBuilderFlush)

flush :: (Monad m) => ConduitT i (Flush o) m ()
flush = yield Flush

yield' :: (Monad m) => o -> ConduitT i (Flush o) m ()
yield' = yield . Chunk

doctypehtml :: (Monad m) => ConduitT i (Flush Event) m ()
doctypehtml = do
  yield' $ EventBeginDoctype "html" Nothing
  yield' EventEndDoctype

-- | Generate a complete XML 'Element'.
tag ::
  (Monad m) =>
  Name ->
  Attributes ->
  -- | 'Element''s subnodes.
  ConduitT i (Flush Event) m () ->
  ConduitT i (Flush Event) m ()
tag name (Attributes a) content' = do
  yield' $ EventBeginElement name a
  content'
  yield' $ EventEndElement name

-- | Generate a textual 'EventContent'.
content :: (Monad m) => Text -> ConduitT i (Flush Event) m ()
content = yield' . EventContent . ContentText

-- | A list of attributes.
newtype Attributes = Attributes [(Name, [Content])]

instance Monoid Attributes where
  mempty = Attributes mempty

instance Semigroup Attributes where
  (Attributes a) <> (Attributes b) = Attributes (a <> b)

-- | Generate a single attribute.
attr ::
  -- | Attribute's name
  Name ->
  -- | Attribute's value
  Text ->
  Attributes
attr name value = Attributes [(name, [ContentText value])]

-- | Helper function that generates a valid attribute if input isn't 'Nothing', or 'mempty' otherwise.
optionalAttr :: Name -> Maybe Text -> Attributes
optionalAttr name = maybe mempty (attr name)

title_, div_, h1_, p_, ul_, li_, slot_, template_ :: (Monad m) => Attributes -> ConduitT i (Flush Event) m () -> ConduitT i (Flush Event) m ()
title_ = tag "title"
h1_ = tag "h1"
p_ = tag "p"
ul_ = tag "ul"
li_ = tag "li"
slot_ = tag "slot"
template_ = tag "template"
div_ = tag "div"

name_ :: Text -> Attributes
name_ = attr "name"

shadowrootmode_ :: Text -> Attributes
shadowrootmode_ = attr "shadowrootmode"

page :: (Monad m, MonadIO m) => ConduitT i (Flush Event) m ()
page = do
  doctypehtml
  title_ mempty do
    content "Hello, World!"
  tag "div" mempty do
    template_ (shadowrootmode_ "open") do
      tag "header" mempty do
        h1_ mempty do
          content "Hello, World!"
      tag "main" mempty do
        slot_ (name_ "content") (p_ mempty (content "Loading content ..."))
      tag "footer" mempty do
        p_ mempty do
          content "Goodbye, World!"
    flush
    liftIO $ threadDelay 1000000
    ul_ (attr "slot" "content") do
      forM_ [1 .. 10] \i -> li_ mempty do
        content $ "Item " <> pack (show i)

rendered :: ConduitT () (Flush Builder) IO ()
rendered = page .| renderBuilderFlush def

app :: Application
app _ respond =
  respond $
    responseSource
      status200
      [("Content-Type", "text/html")]
      rendered

someFunc :: IO ()
someFunc = run 8080 app