mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-01-11 05:16:45 +09:00
116 lines
3.1 KiB
Haskell
116 lines
3.1 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 Network.FedURI
|
|
( FedURI (..)
|
|
, parseFedURI
|
|
, toURI
|
|
, renderFedURI
|
|
|
|
, InstanceURI (..)
|
|
, i2f
|
|
, f2i
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Control.Monad ((<=<))
|
|
import Data.Aeson
|
|
import Data.Bifunctor (first)
|
|
import Data.Text (Text)
|
|
import Database.Persist.Class (PersistField (..))
|
|
import Database.Persist.Sql (PersistFieldSql (..))
|
|
import Network.URI
|
|
|
|
import qualified Data.Text as T (pack, unpack)
|
|
|
|
-- | An absolute URI with the following properties:
|
|
--
|
|
-- * The scheme is HTTPS
|
|
-- * The authority part is present
|
|
-- * The authority part doesn't have userinfo
|
|
-- * The authority part doesn't have a port number
|
|
-- * There is no query part
|
|
-- * A fragment part may be present
|
|
data FedURI = FedURI
|
|
{ furiHost :: Text
|
|
, furiPath :: Text
|
|
, furiFragment :: Text
|
|
}
|
|
deriving Eq
|
|
|
|
instance FromJSON FedURI where
|
|
parseJSON = withText "FedURI" $ either fail return . parseFedURI
|
|
|
|
instance ToJSON FedURI where
|
|
toJSON = error "toJSON FedURI"
|
|
toEncoding = toEncoding . renderFedURI
|
|
|
|
instance PersistField FedURI where
|
|
toPersistValue = toPersistValue . renderFedURI
|
|
fromPersistValue = first T.pack . parseFedURI <=< fromPersistValue
|
|
|
|
instance PersistFieldSql FedURI where
|
|
sqlType = sqlType . fmap renderFedURI
|
|
|
|
parseFedURI :: Text -> Either String FedURI
|
|
parseFedURI t = do
|
|
uri <- case parseURI $ T.unpack t of
|
|
Nothing -> Left "Invalid absolute URI"
|
|
Just u -> Right u
|
|
if uriScheme uri == "https:"
|
|
then Right ()
|
|
else Left "URI scheme isn't https"
|
|
URIAuth ui h p <- case uriAuthority uri of
|
|
Nothing -> Left "URI has empty authority"
|
|
Just a -> Right a
|
|
if ui == ""
|
|
then Right ()
|
|
else Left "URI has non-empty userinfo"
|
|
if p == ""
|
|
then Right ()
|
|
else Left "URI has non-empty port"
|
|
if uriQuery uri == ""
|
|
then Right ()
|
|
else Left "URI query is non-empty"
|
|
Right FedURI
|
|
{ furiHost = T.pack h
|
|
, furiPath = T.pack p
|
|
, furiFragment = T.pack $ uriFragment uri
|
|
}
|
|
|
|
toURI :: FedURI -> URI
|
|
toURI (FedURI h p f) = URI
|
|
{ uriScheme = "https:"
|
|
, uriAuthority = Just $ URIAuth "" (T.unpack h) ""
|
|
, uriPath = T.unpack p
|
|
, uriQuery = ""
|
|
, uriFragment = T.unpack f
|
|
}
|
|
|
|
renderFedURI :: FedURI -> Text
|
|
renderFedURI = T.pack . flip (uriToString id) "" . toURI
|
|
|
|
newtype InstanceURI = InstanceURI
|
|
{ iuriHost :: Text
|
|
}
|
|
deriving Eq
|
|
|
|
i2f :: InstanceURI -> FedURI
|
|
i2f (InstanceURI h) = FedURI h "" ""
|
|
|
|
f2i :: FedURI -> InstanceURI
|
|
f2i = InstanceURI . furiHost
|