{-# LANGUAGE OverloadedLabels #-}
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
servePageWith :: RoutePattern -> PageConfig -> Page -> ScottyM ()
servePageWith :: RoutePattern -> PageConfig -> Page -> ScottyT Text IO ()
servePageWith RoutePattern
rp PageConfig
pc Page
p =
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ [ScottyT Text IO ()]
servedir forall a. Semigroup a => a -> a -> a
<> [ScottyT Text IO ()
getpage]
where
getpage :: ScottyT Text IO ()
getpage = case PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "concerns" a => a
#concerns of
PageConcerns
Inline ->
RoutePattern -> ActionM () -> ScottyT Text IO ()
get RoutePattern
rp (Text -> ActionM ()
html forall a b. (a -> b) -> a -> b
$ FilePath -> Text
pack forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
utf8ToStr forall a b. (a -> b) -> a -> b
$ RenderStyle -> Standard -> Markup -> ByteString
markdown_ RenderStyle
Compact Standard
Html 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 Text IO ()
middleware forall a b. (a -> b) -> a -> b
$ Policy -> Middleware
staticPolicy forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)] -> Policy
only [(FilePath
cssfp, FilePath
cssfp), (FilePath
jsfp, FilePath
jsfp)]
RoutePattern -> ActionM () -> ScottyT Text IO ()
get
RoutePattern
rp
( do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
writeFile' FilePath
cssfp ByteString
css
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
writeFile' FilePath
jsfp ByteString
js
Text -> ActionM ()
html forall a b. (a -> b) -> a -> b
$ FilePath -> Text
pack forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
utf8ToStr forall a b. (a -> b) -> a -> b
$ RenderStyle -> Standard -> Markup -> ByteString
markdown_ RenderStyle
Compact Standard
Html Markup
h
)
cssfp :: FilePath
cssfp = PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "filenames" a => a
#filenames 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
% forall a. IsLabel "cssConcern" a => a
#cssConcern
jsfp :: FilePath
jsfp = PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "filenames" a => a
#filenames 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
% forall a. IsLabel "jsConcern" a => a
#jsConcern
writeFile' :: FilePath -> ByteString -> IO ()
writeFile' FilePath
fp ByteString
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
s forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty) (FilePath -> ByteString -> IO ()
B.writeFile FilePath
fp ByteString
s)
servedir :: [ScottyT Text IO ()]
servedir = (\FilePath
x -> Middleware -> ScottyT Text IO ()
middleware forall a b. (a -> b) -> a -> b
$ Policy -> Middleware
staticPolicy (Policy
noDots forall a. Semigroup a => a -> a -> a
<> FilePath -> Policy
addBase FilePath
x)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PageConfig
pc forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "localdirs" a => a
#localdirs