mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-15 19:25:07 +09:00
57 lines
1.6 KiB
Haskell
57 lines
1.6 KiB
Haskell
|
{- This file is part of Vervis.
|
||
|
|
-
|
||
|
|
- Written 2019, 2023 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/>.
|
||
|
|
-}
|
||
|
|
|
||
|
|
-- | Tools for integrating 'Web.Actor' with the Yesod web framework.
|
||
|
|
module Yesod.Actor
|
||
|
|
( decodeRouteLocal
|
||
|
|
, parseLocalURI
|
||
|
|
, StageYesod (..)
|
||
|
|
, parseFedURI
|
||
|
|
)
|
||
|
|
where
|
||
|
|
|
||
|
|
import Control.Monad.Trans.Except
|
||
|
|
import Data.Text (Text)
|
||
|
|
import Data.Text.Encoding
|
||
|
|
import Network.HTTP.Types.URI
|
||
|
|
import Yesod.Core
|
||
|
|
|
||
|
|
import Network.FedURI
|
||
|
|
import Web.Actor
|
||
|
|
|
||
|
|
import Control.Monad.Trans.Except.Local
|
||
|
|
|
||
|
|
decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site)
|
||
|
|
decodeRouteLocal =
|
||
|
|
parseRoute . (,[]) . decodePathSegments . encodeUtf8 . localUriPath
|
||
|
|
|
||
|
|
parseLocalURI
|
||
|
|
:: (Monad m, ParseRoute site)
|
||
|
|
=> LocalURI -> ExceptT Text m (Route site)
|
||
|
|
parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"
|
||
|
|
|
||
|
|
class (StageWeb s, Yesod (StageSite s)) => StageYesod s where
|
||
|
|
type StageSite s
|
||
|
|
|
||
|
|
parseFedURI
|
||
|
|
:: (StageYesod s, ParseRoute (StageSite s))
|
||
|
|
=> ObjURI (StageURIMode s)
|
||
|
|
-> ActForE s (Either (Route (StageSite s)) (ObjURI (StageURIMode s)))
|
||
|
|
parseFedURI u@(ObjURI h lu) = do
|
||
|
|
hl <- lift $ hostIsLocal h
|
||
|
|
if hl
|
||
|
|
then Left <$> parseLocalURI lu
|
||
|
|
else pure $ Right u
|