sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 17:24:53 +09:00
Code Issues Activity

New datatype FedURI for @id URIs

Browse source 
Using a dedicated type allows to record in the type the guarantees that we
provide, such as scheme being HTTPS and authority being present. Allows to
replace ugly `fromJust` and such with direct field access.
This commit is contained in:
fr33domlover 2019-02-07 23:08:28 +00:00
parent e325175a9c
commit 8ac559d064
12 changed files with 176 additions and 128 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
config/models
View file

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

4
migrations/2019_02_03_verifkey.model
View file

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

23
src/Data/Aeson/Local.hs
View file

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

14
src/Database/Persist/Class/Local.hs
View file

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

5
src/Database/Persist/Sql/Local.hs
View file

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

101
src/Network/FedURI.hs Normal file
View file

@ -0,0 +1,101 @@
{- 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
)
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

18
src/Vervis/Foundation.hs
View file

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

27
src/Vervis/Handler/Inbox.hs
View file

@ -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 $

8
src/Vervis/Handler/Person.hs
View file

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

2
src/Vervis/Model.hs
View file

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

97
src/Web/ActivityPub.hs
View file

@ -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"

1
vervis.cabal
View file

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