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

    , FedPageURI (..)
    , LocalPageURI (..)
    , lp2fp
    , fp2lp
    )
where

import Prelude

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

import qualified Data.Text as T

-- | 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 host needs to match certain rules
-- * 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 any (== '.') h
        then Right ()
        else Left "Host doesn't contain periods"
    if any isAsciiLetter h
        then Right ()
        else Left "Host doesn't contain ASCII letters"
    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
        }
    where
    isAsciiLetter c = isAsciiLower c || isAsciiUpper c

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

-- | A 'FedURI' with a page number specified as a query parameter
data FedPageURI = FedPageURI
    { fpuriResource :: FedURI
    , fpuriParam    :: Text
    , fpuriPage     :: Int
    }
    deriving (Eq, Generic)

instance Hashable FedPageURI

instance FromJSON FedPageURI where
    parseJSON = withText "FedPageURI" $ either fail return . parseFedPageURI

instance ToJSON FedPageURI where
    toJSON = error "toJSON FedPageURI"
    toEncoding = toEncoding . renderFedPageURI

parseFedPageURI :: Text -> Either String FedPageURI
parseFedPageURI 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 any (== '.') h
        then Right ()
        else Left "Host doesn't contain periods"
    if any isAsciiLetter h
        then Right ()
        else Left "Host doesn't contain ASCII letters"
    (param, mval) <-
        case parseQueryText $ encodeUtf8 $ T.pack $ uriQuery uri of
            [] -> Left "URI query is empty"
            [qp] -> Right qp
            _ -> Left "URI has multiple query parameters"
    val <-
        case mval of
            Nothing -> Left "URI query parameter doesn't have a value"
            Just v -> Right v
    page <-
        case readMaybe $ T.unpack val of
            Nothing -> Left "URI query param value isn't an integer"
            Just n -> Right n
    if page >= 1
        then Right ()
        else Left "URI page number isn't positive"
    Right FedPageURI
        { fpuriResource = FedURI
            { furiHost     = T.pack h
            , furiPath     = T.pack $ uriPath uri
            , furiFragment = T.pack $ uriFragment uri
            }
        , fpuriParam = param
        , fpuriPage  = page
        }
    where
    isAsciiLetter c = isAsciiLower c || isAsciiUpper c

toPageURI :: FedPageURI -> URI
toPageURI (FedPageURI (FedURI h p f) qp qv) = URI
    { uriScheme    = "https:"
    , uriAuthority = Just $ URIAuth "" (T.unpack h) ""
    , uriPath      = T.unpack p
    , uriQuery     = "?" ++ T.unpack qp ++ "=" ++ show qv
    , uriFragment  = T.unpack f
    }

renderFedPageURI :: FedPageURI -> Text
renderFedPageURI = T.pack . flip (uriToString id) "" . toPageURI

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

data LocalPageURI = LocalPageURI
    { lpuriResource :: LocalURI
    , lpuriParam    :: Text
    , lpuriPage     :: Int
    }
    deriving Eq

lp2fp :: Text -> LocalPageURI -> FedPageURI
lp2fp h (LocalPageURI lu p n) = FedPageURI (l2f h lu) p n

fp2lp :: FedPageURI -> (Text, LocalPageURI)
fp2lp (FedPageURI fu p n) =
    let (h, lu) = f2l fu
    in  (h, LocalPageURI lu p n)