{-# LANGUAGE OverloadedLabels #-}

-- | Serve pages via 'ScottyM'
module Web.Rep.Server
  ( servePageWith,
  )
where

import Control.Monad
import Control.Monad.Trans.Class
import Data.ByteString qualified as B
import Data.Text.Lazy (pack)
import MarkupParse
import Network.Wai.Middleware.Static (addBase, noDots, only, staticPolicy)
import Optics.Core hiding (only)
import Web.Rep.Page
import Web.Rep.Render
import Web.Scotty

-- | serve a Page via a ScottyM
servePageWith :: RoutePattern -> PageConfig -> Page -> ScottyM ()
servePageWith :: RoutePattern -> PageConfig -> Page -> ScottyT IO ()
servePageWith RoutePattern
rp PageConfig
pc Page
p =
  [ScottyT IO ()] -> ScottyT IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([ScottyT IO ()] -> ScottyT IO ())
-> [ScottyT IO ()] -> ScottyT IO ()
forall a b. (a -> b) -> a -> b
$ [ScottyT IO ()]
servedir [ScottyT IO ()] -> [ScottyT IO ()] -> [ScottyT IO ()]
forall a. Semigroup a => a -> a -> a
<> [ScottyT IO ()
getpage]
  where
    getpage :: ScottyT IO ()
getpage = case PageConfig
pc PageConfig
-> Optic' A_Lens NoIx PageConfig PageConcerns -> PageConcerns
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx PageConfig PageConcerns
#concerns of
      PageConcerns
Inline ->
        RoutePattern -> ActionM () -> ScottyT IO ()
get RoutePattern
rp (Text -> ActionM ()
html (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
utf8ToStr (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ RenderStyle -> Standard -> Markup -> ByteString
markdown_ RenderStyle
Compact Standard
Html (Markup -> ByteString) -> Markup -> ByteString
forall a b. (a -> b) -> a -> b
$ PageConfig -> Page -> Markup
renderPageHtmlWith PageConfig
pc Page
p)
      PageConcerns
Separated ->
        let (ByteString
css, ByteString
js, Markup
h) = PageConfig -> Page -> (ByteString, ByteString, Markup)
renderPageWith PageConfig
pc Page
p
         in do
              Middleware -> ScottyT IO ()
middleware (Middleware -> ScottyT IO ()) -> Middleware -> ScottyT IO ()
forall a b. (a -> b) -> a -> b
$ Policy -> Middleware
staticPolicy (Policy -> Middleware) -> Policy -> Middleware
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> Policy
only [(String
cssfp, String
cssfp), (String
jsfp, String
jsfp)]
              RoutePattern -> ActionM () -> ScottyT IO ()
get
                RoutePattern
rp
                ( do
                    IO () -> ActionM ()
forall (m :: * -> *) a. Monad m => m a -> ActionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
writeFile' String
cssfp ByteString
css
                    IO () -> ActionM ()
forall (m :: * -> *) a. Monad m => m a -> ActionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
writeFile' String
jsfp ByteString
js
                    Text -> ActionM ()
html (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
utf8ToStr (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ RenderStyle -> Standard -> Markup -> ByteString
markdown_ RenderStyle
Compact Standard
Html Markup
h
                )
    cssfp :: String
cssfp = PageConfig
pc PageConfig -> Optic' A_Lens NoIx PageConfig String -> String
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic
  A_Lens
  NoIx
  PageConfig
  PageConfig
  (Concerns String)
  (Concerns String)
#filenames Optic
  A_Lens
  NoIx
  PageConfig
  PageConfig
  (Concerns String)
  (Concerns String)
-> Optic
     A_Lens NoIx (Concerns String) (Concerns String) String String
-> Optic' A_Lens NoIx PageConfig String
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx (Concerns String) (Concerns String) String String
#cssConcern
    jsfp :: String
jsfp = PageConfig
pc PageConfig -> Optic' A_Lens NoIx PageConfig String -> String
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic
  A_Lens
  NoIx
  PageConfig
  PageConfig
  (Concerns String)
  (Concerns String)
#filenames Optic
  A_Lens
  NoIx
  PageConfig
  PageConfig
  (Concerns String)
  (Concerns String)
-> Optic
     A_Lens NoIx (Concerns String) (Concerns String) String String
-> Optic' A_Lens NoIx PageConfig String
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx (Concerns String) (Concerns String) String String
#jsConcern
    writeFile' :: String -> ByteString -> IO ()
writeFile' String
fp ByteString
s = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
s ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
forall a. Monoid a => a
mempty) (String -> ByteString -> IO ()
B.writeFile String
fp ByteString
s)
    servedir :: [ScottyT IO ()]
servedir = (\String
x -> Middleware -> ScottyT IO ()
middleware (Middleware -> ScottyT IO ()) -> Middleware -> ScottyT IO ()
forall a b. (a -> b) -> a -> b
$ Policy -> Middleware
staticPolicy (Policy
noDots Policy -> Policy -> Policy
forall a. Semigroup a => a -> a -> a
<> String -> Policy
addBase String
x)) (String -> ScottyT IO ()) -> [String] -> [ScottyT IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PageConfig
pc PageConfig -> Optic' A_Lens NoIx PageConfig [String] -> [String]
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx PageConfig [String]
#localdirs