49 lines
1.7 KiB
Haskell
49 lines
1.7 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Utils.Approot
|
|
( approotScopeHost, approotScopeBaseUrl, approotScopeHost'
|
|
, approotRender
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (Proxy)
|
|
import Settings
|
|
|
|
import Utils.Route
|
|
|
|
import Network.URI (URI(URI), URIAuth(URIAuth))
|
|
import qualified Network.URI as URI
|
|
|
|
import Control.Lens
|
|
|
|
import Data.Proxy
|
|
|
|
|
|
approotScopeHost' :: HasAppSettings site => (URI -> URIAuth -> a) -> ApprootScope -> site -> Maybe a
|
|
approotScopeHost' f rApproot app = do
|
|
approotText <- views _appRoot ($ rApproot) app
|
|
approotURI <- URI.parseURI $ unpack approotText
|
|
approotAuthority <- URI.uriAuthority approotURI
|
|
return $ f approotURI approotAuthority
|
|
|
|
approotScopeHost :: HasAppSettings site => ApprootScope -> site -> Maybe ByteString
|
|
approotScopeHost = approotScopeHost' $ \_ URIAuth{..}
|
|
-> encodeUtf8 . pack $ uriRegName <> uriPort
|
|
|
|
approotScopeBaseUrl :: HasAppSettings site => ApprootScope -> site -> Maybe Text
|
|
approotScopeBaseUrl = approotScopeHost' $ \URI{..} URIAuth{..}
|
|
-> pack $ uriScheme <> "//" <> uriRegName <> uriPort
|
|
|
|
approotRender :: forall url m.
|
|
( HasAppSettings (HandlerSite m)
|
|
, MonadHandler m
|
|
, Yesod (HandlerSite m)
|
|
, HasRoute (HandlerSite m) url
|
|
)
|
|
=> ApprootScope -> url -> m Text
|
|
approotRender rApproot route = do
|
|
app <- getYesod
|
|
approotHost <- maybe (getApprootText approot app <$> waiRequest) return $ approotScopeBaseUrl rApproot app
|
|
return . yesodRender app approotHost (urlRoute route) . withLens (urlRouteParams (Proxy @(HandlerSite m))) $ \g _ -> g route
|