mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-15 18:55:08 +09:00
92 lines
2.9 KiB
Haskell
92 lines
2.9 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written 2019 by fr33domlover <fr33domlover@riseup.net>.
|
|
-
|
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
-
|
|
- The author(s) have dedicated all copyright and related and neighboring
|
|
- rights to this software to the public domain worldwide. This software is
|
|
- distributed without any warranty.
|
|
-
|
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
- with this software. If not, see
|
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
-}
|
|
|
|
module Yesod.FedURI
|
|
( getEncodeRouteLocal
|
|
, getEncodeRouteHome
|
|
, getEncodeRouteFed
|
|
, decodeRouteLocal
|
|
, getEncodeRoutePageLocal
|
|
, getEncodeRoutePageHome
|
|
, getEncodeRoutePageFed
|
|
)
|
|
where
|
|
|
|
import Control.Monad
|
|
import Data.Text (Text)
|
|
import Data.Text.Encoding
|
|
import Network.HTTP.Types.URI
|
|
import Yesod.Core
|
|
import Yesod.Core.Handler
|
|
|
|
import qualified Data.Text as T
|
|
|
|
import Network.FedURI
|
|
import Yesod.MonadSite
|
|
|
|
import Yesod.Paginate.Local
|
|
|
|
getEncodeRouteLocal :: MonadSite m => m (Route (SiteEnv m) -> LocalURI)
|
|
getEncodeRouteLocal = (\ f -> snd . f2l . f) <$> getEncodeRouteHome
|
|
|
|
getEncodeRouteHome :: MonadSite m => m (Route (SiteEnv m) -> FedURI)
|
|
getEncodeRouteHome = toFed <$> askUrlRender
|
|
where
|
|
toFed renderUrl route =
|
|
case parseFedURI $ renderUrl route of
|
|
Left e -> error $ "getUrlRender produced invalid FedURI: " ++ e
|
|
Right u -> u
|
|
|
|
getEncodeRouteFed :: MonadSite m => m (Text -> Route (SiteEnv m) -> FedURI)
|
|
getEncodeRouteFed = toFed <$> askUrlRender
|
|
where
|
|
toFed renderUrl host route =
|
|
case parseFedURI $ renderUrl route of
|
|
Left e -> error $ "getUrlRender produced invalid FedURI: " ++ e
|
|
Right u -> u { furiHost = host }
|
|
|
|
decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site)
|
|
decodeRouteLocal =
|
|
parseRoute . (,[]) . decodePathSegments . encodeUtf8 . luriPath <=< noFrag
|
|
where
|
|
noFrag lu =
|
|
if T.null $ luriFragment lu
|
|
then Just lu
|
|
else Nothing
|
|
|
|
getEncodeRoutePageLocal
|
|
:: (MonadSite m, YesodPaginate (SiteEnv m))
|
|
=> m (Route (SiteEnv m) -> Int -> LocalPageURI)
|
|
getEncodeRoutePageLocal = do
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
param <- asksSite sitePageParamName
|
|
return $ \ route page -> LocalPageURI (encodeRouteLocal route) param page
|
|
|
|
getEncodeRoutePageHome
|
|
:: (MonadSite m, YesodPaginate (SiteEnv m))
|
|
=> m (Route (SiteEnv m) -> Int -> FedPageURI)
|
|
getEncodeRoutePageHome = do
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
param <- asksSite sitePageParamName
|
|
return $ \ route page -> FedPageURI (encodeRouteHome route) param page
|
|
|
|
getEncodeRoutePageFed
|
|
:: (MonadSite m, YesodPaginate (SiteEnv m))
|
|
=> m (Text -> Route (SiteEnv m) -> Int -> FedPageURI)
|
|
getEncodeRoutePageFed = do
|
|
encodeRouteFed <- getEncodeRouteFed
|
|
param <- asksSite sitePageParamName
|
|
return $
|
|
\ host route page -> FedPageURI (encodeRouteFed host route) param page
|