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/>.
 -}

{-# LANGUAGE DeriveGeneric #-}

module Network.FedURI
    ( FedURI (..)
    , parseFedURI
    , toURI
    , renderFedURI

    {-
    , InstanceURI (..)
    , i2f
    , f2i
    -}

    , LocalURI (..)
    , l2f
    , f2l
    )
where

import Prelude

import Control.Monad ((<=<))
import Data.Aeson
import Data.Bifunctor (bimap, first)
import Data.Hashable
import Data.Maybe (fromJust)
import Data.Text (Text)
import Database.Persist.Class (PersistField (..))
import Database.Persist.Sql (PersistFieldSql (..))
import GHC.Generics (Generic)
import Network.URI

import qualified Data.Text as T (pack, unpack, stripPrefix)

-- | 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, Generic)

instance Hashable FedURI

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 $ uriPath uri
        , 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
-}

data LocalURI = LocalURI
    { luriPath     :: Text
    , luriFragment :: Text
    }
    deriving Eq

dummyHost :: Text
dummyHost = "h"

dummyPrefix :: Text
dummyPrefix = "https://" <> dummyHost

renderLocalURI :: LocalURI -> Text
renderLocalURI = fromJust . T.stripPrefix dummyPrefix . renderFedURI . l2f dummyHost

instance PersistField LocalURI where
    toPersistValue = toPersistValue . renderLocalURI
    fromPersistValue = bimap T.pack (snd . f2l) . parseFedURI . (dummyPrefix <>) <=< fromPersistValue

instance PersistFieldSql LocalURI where
    sqlType = sqlType . fmap renderLocalURI

l2f :: Text -> LocalURI -> FedURI
l2f h (LocalURI p f) = FedURI h p f

f2l :: FedURI -> (Text, LocalURI)
f2l (FedURI h p f) = (h, LocalURI p f)