diff --git a/config/models b/config/models index 08f4ade..5a833cc 100644 --- a/config/models +++ b/config/models @@ -40,7 +40,7 @@ Person UniquePersonEmail email VerifKey - ident URI + ident FedURI instance InstanceId expires UTCTime Maybe public PublicKey @@ -49,7 +49,7 @@ VerifKey UniqueVerifKey ident RemoteSharer - ident URI + ident FedURI instance InstanceId UniqueRemoteSharer ident diff --git a/migrations/2019_02_03_verifkey.model b/migrations/2019_02_03_verifkey.model index 79dbd9c..113b886 100644 --- a/migrations/2019_02_03_verifkey.model +++ b/migrations/2019_02_03_verifkey.model @@ -1,5 +1,5 @@ VerifKey - ident String + ident Text instance InstanceId expires UTCTime Maybe public ByteString @@ -8,7 +8,7 @@ VerifKey UniqueVerifKey ident RemoteSharer - ident String + ident Text instance InstanceId UniqueRemoteSharer ident diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index 82a822e..3a71cd3 100644 --- a/src/Data/Aeson/Local.hs +++ b/src/Data/Aeson/Local.hs @@ -18,9 +18,6 @@ module Data.Aeson.Local , toEither , fromEither , frg - , parseHttpsURI' - , parseHttpsURI - , renderURI , (.=?) ) where @@ -56,26 +53,6 @@ fromEither (Right y) = Right' y frg :: Text frg = "https://forgefed.angeley.es/ns#" -parseHttpsURI' :: Text -> Either String URI -parseHttpsURI' t = - case parseURI $ T.unpack t of - Nothing -> Left "Invalid absolute URI" - Just u -> - if uriScheme u == "https:" - then case uriAuthority u of - Just a -> - if uriUserInfo a == "" && uriPort a == "" - then Right u - else Left "URI has userinfo or port" - Nothing -> Left "URI has empty authority" - else Left "URI scheme isn't https" - -parseHttpsURI :: Text -> Parser URI -parseHttpsURI = either fail return . parseHttpsURI' - -renderURI :: URI -> String -renderURI u = uriToString id u "" - infixr 8 .=? (.=?) :: ToJSON v => Text -> Maybe v -> Series _ .=? Nothing = mempty diff --git a/src/Database/Persist/Class/Local.hs b/src/Database/Persist/Class/Local.hs index d709682..71b74f5 100644 --- a/src/Database/Persist/Class/Local.hs +++ b/src/Database/Persist/Class/Local.hs @@ -34,24 +34,10 @@ import Network.URI (URI, uriScheme, parseURI) import qualified Data.CaseInsensitive as CI import qualified Data.Text as T (pack) -import Data.Aeson.Local (renderURI) - instance (PersistField s, CI.FoldCase s) => PersistField (CI s) where toPersistValue = toPersistValue . CI.original fromPersistValue = fmap CI.mk . fromPersistValue -instance PersistField URI where - toPersistValue = toPersistValue . renderURI - fromPersistValue = parseHttpsURI <=< fromPersistValue - where - parseHttpsURI s = - case parseURI s of - Nothing -> Left "Invalid absolute URI" - Just u -> - if uriScheme u == "https:" - then Right u - else Left "URI scheme isn't https" - instance PersistField PublicKey where toPersistValue = toPersistValue . convert' where diff --git a/src/Database/Persist/Sql/Local.hs b/src/Database/Persist/Sql/Local.hs index 541450e..ea9582d 100644 --- a/src/Database/Persist/Sql/Local.hs +++ b/src/Database/Persist/Sql/Local.hs @@ -25,19 +25,14 @@ import Data.ByteArray (convert) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import Database.Persist.Sql -import Network.URI (URI) import qualified Data.CaseInsensitive as CI -import Data.Aeson.Local (renderURI) import Database.Persist.Class.Local () instance (PersistFieldSql s, CI.FoldCase s) => PersistFieldSql (CI s) where sqlType = sqlType . fmap CI.original -instance PersistFieldSql URI where - sqlType = sqlType . fmap renderURI - instance PersistFieldSql PublicKey where sqlType = sqlType . fmap convert' where diff --git a/src/Network/FedURI.hs b/src/Network/FedURI.hs new file mode 100644 index 0000000..53e4189 --- /dev/null +++ b/src/Network/FedURI.hs @@ -0,0 +1,101 @@ +{- This file is part of Vervis. + - + - Written 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Network.FedURI + ( FedURI (..) + , parseFedURI + , toURI + , renderFedURI + ) +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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 257b2e8..a9c464c 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -57,9 +57,9 @@ import Yesod.Mail.Send import qualified Network.HTTP.Signature as S (Algorithm (..)) +import Network.FedURI import Web.ActivityPub -import Data.Aeson.Local (parseHttpsURI') import Text.Email.Local import Text.Jasmine.Local (discardm) @@ -562,8 +562,8 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding instance YesodHttpSig App where - data HttpSigVerResult App = HttpSigVerResult (Either String URI) - httpSigVerHeaders = const [hRequestTarget, hHost, "ActivityPub-Actor"] + data HttpSigVerResult App = HttpSigVerResult (Either String FedURI) + httpSigVerHeaders = const [hRequestTarget, hHost, hActivityPubActor] httpSigVerSeconds = fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings where @@ -576,20 +576,20 @@ instance YesodHttpSig App where case algo of S.AlgorithmEd25519 -> Right () S.AlgorithmOther _ -> Left "Unsupported algo in Sig header" - u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of - Nothing -> Left "keyId in Sig header isn't a valid absolute URI" - Just uri -> Right uri + u <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of + Left e -> Left $ "keyId in Sig header isn't a valid FedURI: " ++ e + Right uri -> Right uri signature <- ExceptT . pure $ do case signature sig of CryptoPassed s -> Right s CryptoFailed e -> Left "Parsing Ed25519 signature failed" muActorHeader <- do - bs <- lookupHeaders "ActivityPub-Actor" + bs <- lookupHeaders hActivityPubActor case bs of [] -> return Nothing [b] -> fmap Just . ExceptT . pure $ do t <- first displayException $ decodeUtf8' b - parseHttpsURI' t + parseFedURI t _ -> throwE "Multiple ActivityPub-Actor headers" (mvkid, key, mexpires, uActor, host, shared) <- do ments <- lift $ runDB $ do @@ -612,7 +612,7 @@ instance YesodHttpSig App where , verifKeyPublic vk , verifKeyExpires vk , ua - , T.pack $ uriRegName $ fromJust $ uriAuthority uKey + , furiHost uKey , s ) Nothing -> do diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 056efef..995f36e 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -49,7 +49,6 @@ import Database.Persist (Entity (..)) import Network.HTTP.Client (Manager, HttpException, requestFromURI) import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader) import Network.HTTP.Types.Header (hDate, hHost) -import Network.URI import Text.Blaze.Html (Html) import UnliftIO.Exception (try) import Yesod.Auth (requireAuth) @@ -75,8 +74,7 @@ import Yesod.HttpSignature (verifyRequestSignature) import qualified Network.HTTP.Signature as S (Algorithm (..)) -import Data.Aeson.Local (parseHttpsURI') - +import Network.FedURI import Web.ActivityPub import Vervis.ActorKey @@ -167,9 +165,9 @@ postInboxR = do case M.lookup "actor" o of Nothing -> Left "Activity has no actor member" Just v -> case v of - String t -> case parseURI $ T.unpack t of - Nothing -> Left "Activity actor URI parsing failed" - Just uri -> Right uri + String t -> case parseFedURI t of + Left e -> Left $ "Activity actor URI parsing failed: " ++ e + Right uri -> Right uri _ -> Left "Activity actor isn't a JSON string" liftE $ if activityActor == uActor then Right () @@ -180,9 +178,9 @@ postInboxR = do Object obj -> case M.lookup "actor" obj <|> M.lookup "attributedTo" obj of Nothing -> Right () Just v' -> case v' of - String t -> case parseURI $ T.unpack t of - Nothing -> Left "Activity actor URI parsing failed" - Just uri -> + String t -> case parseFedURI t of + Left e -> Left $ "Activity actor URI parsing failed: " ++ e + Right uri -> if uri == uActor then Right () else Left "Activity object's actor doesn't match activity's actor" @@ -200,12 +198,7 @@ activityForm :: Form Activity activityForm = renderDivs $ areq jsonField "" $ Just defval where defval = Activity - { activityTo = - URI "https:" - (Just $ URIAuth "" "forge.angeley.es" "") - "/p/aviva" - "" - "" + { activityTo = FedURI "forge.angeley.es" "/p/aviva" "" , activityJSON = M.fromList [ "@context" .= ("https://www.w3.org/ns/activitystreams" :: Text) , "type" .= ("Create" :: Text) @@ -292,7 +285,7 @@ postOutboxR = do else (keyID2, akey2) sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) eres' <- httpPostAP manager (actorInbox actor) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID (updateAct act) - case eres of + case eres' of Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e) Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result." defaultLayout $ activityWidget widget enctype @@ -304,7 +297,7 @@ getActorKey choose route = do getsYesod appActorKeys renderUrl <- getUrlRender let route2uri r = - case parseHttpsURI' $ renderUrl r of + case parseFedURI $ renderUrl r of Left e -> error e Right u -> u selectRep $ diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index a255828..df5696c 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -28,7 +28,6 @@ import Vervis.Import hiding ((==.)) --import Prelude import Database.Esqueleto hiding (isNothing, count) -import Network.URI (uriFragment, parseAbsoluteURI) import Vervis.Form.Person --import Model import Text.Blaze.Html (toHtml) @@ -41,6 +40,7 @@ import Yesod.Auth.Unverified (requireUnverifiedAuth) import Text.Email.Local +import Network.FedURI import Web.ActivityPub --import Vervis.ActivityStreams @@ -137,9 +137,9 @@ getPersonR shr = do return p renderUrl <- getUrlRender let route2uri route = - case parseAbsoluteURI $ T.unpack $ renderUrl route of - Nothing -> error "getRenderUrl produced invalid URI!!!" - Just u -> u + case parseFedURI $ renderUrl route of + Left e -> error $ "getRenderUrl produced invalid FedURI!!! " ++ e + Right u -> u me = route2uri $ PersonR shr selectRep $ do provideRep $ do diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index d2da976..b23e842 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -23,12 +23,12 @@ import Yesod hiding (Header, parseTime) import Crypto.PubKey.Ed25519 (PublicKey) import Database.Persist.Quasi import Database.Persist.Sql (fromSqlKey) -import Network.URI (URI) import Text.Email.Validate (EmailAddress) import Yesod.Auth.Account (PersistUserCredentials (..)) import Database.Persist.EmailAddress import Database.Persist.Graph.Class +import Network.FedURI (FedURI) import Vervis.Model.Group import Vervis.Model.Ident diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 92d2a6d..8e2e8d6 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -77,6 +77,8 @@ import qualified Data.HashMap.Strict as M (lookup) import qualified Data.Text as T (pack, unpack) import qualified Data.Vector as V (fromList, toList) +import Network.FedURI + import Data.Aeson.Local as2context :: Text @@ -119,9 +121,9 @@ instance ToJSON Algorithm where AlgorithmOther t -> t data PublicKey = PublicKey - { publicKeyId :: URI + { publicKeyId :: FedURI , publicKeyExpires :: Maybe UTCTime - , publicKeyOwner :: URI + , publicKeyOwner :: FedURI , publicKeyPem :: PEM , publicKeyAlgo :: Maybe Algorithm , publicKeyShared :: Bool @@ -137,9 +139,9 @@ instance FromJSON PublicKey where then return () else fail "PublicKey @type isn't Key" PublicKey - <$> (parseHttpsURI =<< o .: "id") + <$> o .: "id" <*> o .:? "expires" - <*> (parseHttpsURI =<< o .: "owner") + <*> o .: "owner" <*> (parsePEM =<< o .: "publicKeyPem") <*> o .:? (frg <> "algorithm") <*> o .:? (frg <> "shared") .!= False @@ -157,16 +159,16 @@ instance ToJSON PublicKey where toJSON = error "toJSON PublicKey" toEncoding (PublicKey id_ mexpires owner pem malgo shared) = pairs - $ "id" .= renderURI id_ + $ "id" .= id_ <> "expires" .=? mexpires - <> "owner" .= renderURI owner + <> "owner" .= owner <> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem) <> (frg <> "algorithm") .=? malgo <> (frg <> "shared") .= shared data PublicKeySet = PublicKeySet - { publicKey1 :: Either URI PublicKey - , publicKey2 :: Maybe (Either URI PublicKey) + { publicKey1 :: Either FedURI PublicKey + , publicKey2 :: Maybe (Either FedURI PublicKey) } instance FromJSON PublicKeySet where @@ -180,7 +182,7 @@ instance FromJSON PublicKeySet where _ -> fail "More than 2 public keys isn't supported" _ -> PublicKeySet <$> parseKey v <*> pure Nothing where - parseKey = bitraverse parseHttpsURI pure . toEither <=< parseJSON + parseKey = fmap toEither . parseJSON instance ToJSON PublicKeySet where toJSON = error "toJSON PublicKeySet" @@ -189,23 +191,23 @@ instance ToJSON PublicKeySet where Nothing -> toEncoding $ renderKey k1 Just k2 -> toEncodingList [renderKey k1, renderKey k2] where - renderKey = fromEither . first renderURI + renderKey = fromEither data Actor = Actor - { actorId :: URI + { actorId :: FedURI , actorType :: ActorType , actorUsername :: Text - , actorInbox :: URI + , actorInbox :: FedURI , actorPublicKeys :: PublicKeySet } instance FromJSON Actor where parseJSON = withObject "Actor" $ \ o -> Actor - <$> (parseHttpsURI =<< o .: "id") + <$> o .: "id" <*> o .: "type" <*> o .: "preferredUsername" - <*> (parseHttpsURI =<< o .: "inbox") + <*> o .: "inbox" <*> o .: "publicKey" instance ToJSON Actor where @@ -213,10 +215,10 @@ instance ToJSON Actor where toEncoding (Actor id_ typ username inbox pkeys) = pairs $ "@context" .= actorContext - <> "id" .= renderURI id_ + <> "id" .= id_ <> "type" .= typ <> "preferredUsername" .= username - <> "inbox" .= renderURI inbox + <> "inbox" .= inbox <> "publicKey" .= pkeys -- | This may seem trivial, but it exists for a good reason: In the 'FromJSON' @@ -229,7 +231,7 @@ instance ToJSON Actor where -- ByteString, but I guess it's okay for now, and it happens to guarantee the -- JSON we POST has no extra whitespace. data Activity = Activity - { activityTo :: URI + { activityTo :: FedURI , activityJSON :: Object } @@ -269,7 +271,7 @@ instance FromJSON Activity where mto2 <- o .:? "to" to <- case mto <|> mto2 of Nothing -> fail "to not provided" - Just t -> parseHttpsURI t + Just u -> return u return $ Activity to o instance ToJSON Activity where @@ -310,12 +312,11 @@ instance Exception APGetError httpGetAP :: (MonadIO m, FromJSON a) => Manager - -> URI + -> FedURI -> m (Either APGetError (Response a)) httpGetAP manager uri = - if uriScheme uri /= "https:" - then return $ Left $ APGetErrorHTTP $ InvalidUrlException (show uri) "Scheme isn't https" - else liftIO $ mkResult <$> try (httpAPEither manager =<< requestFromURI uri) + liftIO $ + mkResult <$> try (httpAPEither manager =<< requestFromURI (toURI uri)) where lookup' x = map snd . filter ((== x) . fst) mkResult (Left e) = Left $ APGetErrorHTTP e @@ -340,29 +341,27 @@ httpGetAP manager uri = httpPostAP :: (MonadIO m, ToJSON a) => Manager - -> URI + -> FedURI -> NonEmpty HeaderName -> (ByteString -> (KeyId, Signature)) -> Text -> a -> m (Either HttpException (Response ())) httpPostAP manager uri headers sign uActor value = - if uriScheme uri /= "https:" - then return $ Left $ InvalidUrlException (show uri) "Scheme isn't https" - else liftIO $ try $ do - req <- requestFromURI uri - let req' = - setRequestCheckStatus $ - consHeader hContentType typeActivityStreams2LD $ - consHeader hActivityPubActor (encodeUtf8 uActor) $ - req { method = "POST" - , requestBody = RequestBodyLBS $ encode value - } - sign' b = - let (k, s) = sign b - in (Nothing, k, s) - req'' <- signRequest headers sign' Nothing req' - httpNoBody req'' manager + liftIO $ try $ do + req <- requestFromURI $ toURI uri + let req' = + setRequestCheckStatus $ + consHeader hContentType typeActivityStreams2LD $ + consHeader hActivityPubActor (encodeUtf8 uActor) $ + req { method = "POST" + , requestBody = RequestBodyLBS $ encode value + } + sign' b = + let (k, s) = sign b + in (Nothing, k, s) + req'' <- signRequest headers sign' Nothing req' + httpNoBody req'' manager where consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r } @@ -372,7 +371,7 @@ data Fetched = Fetched -- ^ The Ed25519 public key corresponding to the URI we requested. , fetchedKeyExpires :: Maybe UTCTime -- ^ Optional expiration time declared for the key we received. - , fetchedActorId :: URI + , fetchedActorId :: FedURI -- ^ The @id URI of the actor for whom the key's signature applies. , fetchedHost :: Text -- ^ The domain name of the instance from which we got the key. @@ -389,25 +388,21 @@ fetchKey :: MonadIO m => Manager -> Bool - -> Maybe URI - -> URI + -> Maybe FedURI + -> FedURI -> m (Either String Fetched) fetchKey manager sigAlgo muActor uKey = runExceptT $ do - let fetch :: (MonadIO m, FromJSON a) => URI -> ExceptT String m a + let fetch :: (MonadIO m, FromJSON a) => FedURI -> ExceptT String m a fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u obj <- fetch uKey - let inztance = uKey { uriPath = "", uriQuery = "", uriFragment = "" } - authority = - case uriAuthority uKey of - Nothing -> error "BUG! We were supposed to verify URI authority is non-empty!" - Just a -> a + let inztance = uKey { furiPath = "", furiFragment = "" } (actor, pkey, shared) <- case obj of Left' pkey -> do if publicKeyId pkey == uKey then return () else throwE "Public key's ID doesn't match the keyid URI" - if uriAuthority (publicKeyOwner pkey) == Just authority + if furiHost (publicKeyOwner pkey) == furiHost uKey then return () else throwE "Actor and key on different domains, we reject" uActor <- @@ -424,7 +419,7 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do then return (actor, pkey, publicKeyShared pkey) else throwE "Actor publicKey has no URI matching pkey @id" Right' actor -> do - if actorId actor == uKey { uriFragment = "" } + if actorId actor == uKey { furiFragment = "" } then return () else throwE "Actor ID doesn't match the keyid URI we fetched" case muActor of @@ -472,7 +467,7 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do { fetchedPublicKey = k , fetchedKeyExpires = publicKeyExpires pkey , fetchedActorId = actorId actor - , fetchedHost = T.pack $ uriRegName authority + , fetchedHost = furiHost uKey , fetchedKeyShared = shared } CryptoFailed _ -> Left "Parsing Ed25519 public key failed" diff --git a/vervis.cabal b/vervis.cabal index 16f9ba7..9157543 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -75,6 +75,7 @@ library Diagrams.IntransitiveDAG Formatting.CaseInsensitive Language.Haskell.TH.Quote.Local + Network.FedURI Network.HTTP.Client.Conduit.ActivityPub Network.SSH.Local Text.Blaze.Local