72 lines
2.0 KiB
Haskell
72 lines
2.0 KiB
Haskell
-- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE DataKinds,
|
|
TypeOperators,
|
|
FlexibleInstances,
|
|
MultiParamTypeClasses,
|
|
OverloadedStrings #-}
|
|
|
|
module Routes where
|
|
|
|
import Servant
|
|
import Servant.API
|
|
import Servant.Server
|
|
import Network.HTTP.Media ((//), (/:))
|
|
import Data.ByteString.Lazy.Internal (ByteString)
|
|
import Control.Monad.Cont (liftIO)
|
|
|
|
import qualified Data.ByteString.Lazy.UTF8 as BSL.U
|
|
import Templates (renderAppHtml)
|
|
|
|
|
|
directory :: FilePath
|
|
directory = "." -- Directory of the static files
|
|
|
|
data HTML
|
|
newtype HTMLTemplate = HTMLTemp ByteString
|
|
|
|
type Main = Get '[HTML] HTMLTemplate
|
|
type App = "app" :> Get '[HTML] HTMLTemplate
|
|
type Home = Main -- Serve app under /
|
|
:<|> App -- Also serve app under /app
|
|
:<|> Raw -- File server | TODO alternatively keep data after parsing & serve as '[JSON]
|
|
|
|
instance Accept HTML where
|
|
contentType _ = "text" // "html"
|
|
|
|
instance MimeRender HTML ByteString where
|
|
mimeRender _ bs = bs
|
|
|
|
instance MimeUnrender HTML ByteString where
|
|
mimeUnrender _ = Right
|
|
|
|
instance MimeRender HTML HTMLTemplate where
|
|
mimeRender p (HTMLTemp bs) = bs --TODO use encoding function of template library
|
|
|
|
instance MimeUnrender HTML HTMLTemplate where
|
|
mimeUnrender _ = Right . HTMLTemp -- TODO use decoding function
|
|
|
|
|
|
workFlowServer :: Server Home
|
|
workFlowServer = mainServer :<|> appServer :<|> fileServer
|
|
where
|
|
mainServer :: Server Main
|
|
mainServer = handleRequest False
|
|
appServer :: Server App
|
|
appServer = handleRequest True
|
|
fileServer :: Server Raw
|
|
fileServer = serveDirectoryFileServer directory
|
|
handleRequest :: Bool -> Handler HTMLTemplate
|
|
handleRequest appReq = do
|
|
liftIO . putStrLn $ "GET request for main application" ++ if appReq then " @/app" else ""
|
|
html <- liftIO $ BSL.U.fromString <$> renderAppHtml Nothing
|
|
return $ HTMLTemp html
|
|
|
|
userAPI :: Proxy Home
|
|
userAPI = Proxy
|
|
|
|
workFlows :: Application
|
|
workFlows = serve userAPI workFlowServer
|