vervis/src/Network/FedURI.hs

{- 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