me/fedi
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Compare commits

base: me:34590c8a6633e14dbcc8826b852f861cab25de91
Branches Tags
me:trunk
..
compare: me:250f3bd2a03db225a15a33f3f0eac8bbc11eda1e
Branches Tags
me:trunk

No commits in common. "34590c8a6633e14dbcc8826b852f861cab25de91" and "250f3bd2a03db225a15a33f3f0eac8bbc11eda1e" have entirely different histories.
34590c8a66 ... 250f3bd2a0

27 changed files with 327 additions and 483 deletions
Show stats Expand all files Collapse all files

14
Dockerfile
View file

@ -1,14 +0,0 @@
FROM hasufell/alpine-haskell:3.16 AS build
RUN cabal update
COPY . /app/
WORKDIR /app
RUN cabal update
RUN cabal build exe:fedi --enable-executable-static
RUN strip `cabal list-bin fedi`
FROM scratch AS artifact
COPY --from=build /app/dist-newstyle/build/x86_64-linux/*/*/x/*/build/*/fedi .

26
Makefile
View file

@ -1,26 +0,0 @@
.PHONY: format
format:
find ./src -type f -name "*.hs" -exec sh -c 'fourmolu -i {}' \;
find ./app -type f -name "*.hs" -exec sh -c 'fourmolu -i {}' \;
# find ./test -type f -name "*.hs" -exec sh -c 'fourmolu -i {}' \;
.PHONY: clean
clean:
rm -rf ./newdist ./out ./dist-newstyle
.PHONY: build
build: fedi.cabal cabal.project
cabal build all --enable-tests --enable-benchmarks
.PHONY: serve
serve:
FEDI_DETAILS="test/public/details.json" cabal run fedi -- serve
.PHONY: insert
insert:
FEDI_DETAILS="test/public/details.json" cabal run fedi -- insert note.html
.PHONY: docker
docker: fedi.cabal cabal.project clean
DOCKER_BUILDKIT=1 docker build -o ./out/ .
file out/fedi

92
app/DB.hs
View file

@ -1,20 +1,22 @@
-- needed because of a compiler bug with OverloadedRecordDot: -- needed because of a compiler bug with OverloadedRecordDot:
-- <https://play.haskell.org/saved/Xq0ZFrQi> -- <https://play.haskell.org/saved/Xq0ZFrQi>
{-# LANGUAGE FieldSelectors #-} {-# language FieldSelectors #-}
-- | Database interaction -- | Database interaction
module DB ( module DB
module DB, ( module DB
DB.Int64, , DB.Int64
) where )
where
import Control.Monad.IO.Class (liftIO)
import Data.Text qualified as T import Data.Text qualified as T
import Data.Typeable
import Database.Sqlite.Easy qualified as DB import Database.Sqlite.Easy qualified as DB
import Fedi import Fedi
import GHC.Stack (HasCallStack) import GHC.Stack (HasCallStack)
import Text.RawString.QQ import Text.RawString.QQ
import Control.Monad.IO.Class (liftIO)
import Data.Typeable
----------------------- -----------------------
@ -25,14 +27,9 @@ data DB
{ getNotes :: IO [Note] { getNotes :: IO [Note]
, getNote :: DB.Int64 -> IO (Maybe Note) , getNote :: DB.Int64 -> IO (Maybe Note)
, insertNote :: NoteEntry -> IO (DB.Int64, Note) , insertNote :: NoteEntry -> IO (DB.Int64, Note)
, insertFollower , insertFollower ::
:: forall a forall a. Typeable a => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
. (Typeable a) => FollowerEntry -> (DB.Int64 -> IO a) -> IO a , deleteFollower :: FollowerEntry -> IO (Maybe DB.Int64)
-- ^ We use a callback so we can revert if the operation fails.
, deleteFollower
:: forall a
. (Typeable a) => FollowerEntry -> (Maybe DB.Int64 -> IO a) -> IO a
-- ^ We use a callback so we can revert if the operation fails.
, getFollowers :: IO [Follower] , getFollowers :: IO [Follower]
} }
@ -45,14 +42,14 @@ data NoteEntry
, name :: Maybe String , name :: Maybe String
, url :: Maybe Url , url :: Maybe Url
} }
deriving (Show) deriving Show
data FollowerEntry data FollowerEntry
= FollowerEntry = FollowerEntry
{ followId :: T.Text { followId :: T.Text
, actorId :: T.Text , actorId :: T.Text
} }
deriving (Show) deriving Show
data Follower data Follower
= Follower = Follower
@ -60,7 +57,7 @@ data Follower
, followId :: T.Text , followId :: T.Text
, actorId :: T.Text , actorId :: T.Text
} }
deriving (Show) deriving Show
----------------------- -----------------------
@ -83,9 +80,7 @@ mkDB connstr details = do
id' <- insertFollowerToDb follower id' <- insertFollowerToDb follower
liftIO $ handle id' liftIO $ handle id'
, deleteFollower = , deleteFollower =
\follower handle -> DB.withPool pool $ DB.transaction do \follower -> DB.withPool pool (deleteFollowerFromDb follower)
id' <- deleteFollowerFromDb follower
liftIO $ handle id'
, getFollowers = , getFollowers =
DB.withPool pool (getFollowersFromDb $ actorUrl details) DB.withPool pool (getFollowersFromDb $ actorUrl details)
} }
@ -275,7 +270,6 @@ getFollowersSQL url =
|] |]
, [DB.SQLText $ T.pack url] , [DB.SQLText $ T.pack url]
) )
----------------------- -----------------------
-- ** Decode row -- ** Decode row
@ -293,29 +287,27 @@ decodeNoteRow = \case
] -> ] ->
let let
emptyNote = emptyUserNote $ T.unpack actor emptyNote = emptyUserNote $ T.unpack actor
in in (noteid,
( noteid emptyNote
, emptyNote { id = Just $ ObjectId $ T.unpack noteidurl
{ id = Just $ ObjectId $ T.unpack noteidurl , published = Just $ read (T.unpack published)
, published = Just $ read (T.unpack published) , attributedTo = Just $ LLink $ Link $ T.unpack actor
, attributedTo = Just $ LLink $ Link $ T.unpack actor , inReplyTo = LLink . Link <$> inReplyTo
, inReplyTo = LLink . Link <$> inReplyTo , content = Just content
, content = Just content , url = url
, url = url , name = StringName <$> name
, name = StringName <$> name , otype =
, otype = emptyNote.otype
emptyNote.otype { likes =
{ likes = emptyNote.otype.likes
emptyNote.otype.likes { id = Just $ ObjectId $ T.unpack noteidurl <> "/likes"
{ id = Just $ ObjectId $ T.unpack noteidurl <> "/likes" }
} , shares =
, shares = emptyNote.otype.shares
emptyNote.otype.shares { id = Just $ ObjectId $ T.unpack noteidurl <> "/shares"
{ id = Just $ ObjectId $ T.unpack noteidurl <> "/shares" }
} }
} })
}
)
row -> error $ "Couldn't decode row as Note: " <> show row row -> error $ "Couldn't decode row as Note: " <> show row
decodeIntRow :: [DB.SQLData] -> DB.Int64 decodeIntRow :: [DB.SQLData] -> DB.Int64
@ -329,11 +321,11 @@ decodeFollowerRow = \case
, DB.SQLText follower_id , DB.SQLText follower_id
, DB.SQLText actor , DB.SQLText actor
] -> ] ->
Follower Follower
{ myid = myid { myid = myid
, followId = follower_id , followId = follower_id
, actorId = actor , actorId = actor
} }
row -> error $ "Couldn't decode row as Follower: " <> show row row -> error $ "Couldn't decode row as Follower: " <> show row
nullableString :: DB.SQLData -> Maybe (Maybe String) nullableString :: DB.SQLData -> Maybe (Maybe String)

6
app/Html.hs
View file

@ -58,8 +58,7 @@ notesHtml notes = do
-- | A single post as HTML. -- | A single post as HTML.
noteHtml :: Fedi.Note -> Html noteHtml :: Fedi.Note -> Html
noteHtml note = do noteHtml note = do
let let noteid = T.pack (maybe "" (\i -> i.unwrap) note.id)
noteid = T.pack (maybe "" (\i -> i.unwrap) note.id)
H.div_ [H.class_ "note"] $ do H.div_ [H.class_ "note"] $ do
H.div_ [H.class_ "note-header"] $ do H.div_ [H.class_ "note-header"] $ do
case note.name of case note.name of
@ -134,8 +133,7 @@ newNoteHtml details = do
) )
localDateJs :: String localDateJs :: String
localDateJs = localDateJs = [r|
[r|
let collection = document.querySelectorAll(".note-date-published"); let collection = document.querySelectorAll(".note-date-published");
for (let i = 0; i < collection.length; i++) { for (let i = 0; i < collection.length; i++) {

9
app/Main.hs
View file

@ -1,6 +1,5 @@
module Main where module Main where
import Control.Logger.Simple qualified as Log
import DB import DB
import Data.Aeson qualified as A import Data.Aeson qualified as A
import Data.Functor ((<&>)) import Data.Functor ((<&>))
@ -17,6 +16,7 @@ import Network.Wai.Middleware.Routed qualified as Wai
import Routes import Routes
import System.Environment (getArgs, lookupEnv) import System.Environment (getArgs, lookupEnv)
import Web.Twain qualified as Twain import Web.Twain qualified as Twain
import Control.Logger.Simple qualified as Log
data Command data Command
= Serve = Serve
@ -120,10 +120,9 @@ runServer port authMiddleware app = do
auth <- Wai.routedMiddleware matchAdmin <$> pure authMiddleware auth <- Wai.routedMiddleware matchAdmin <$> pure authMiddleware
run port $ run port $
( Logger.logStdoutDev ( Logger.logStdoutDev
. Limit.requestSizeLimitMiddleware Limit.defaultRequestSizeLimitSettings . Limit.requestSizeLimitMiddleware Limit.defaultRequestSizeLimitSettings
. auth . auth
) ) app
app
matchAdmin :: [T.Text] -> Bool matchAdmin :: [T.Text] -> Bool
matchAdmin = any (== "admin") matchAdmin = any (== "admin")

88
app/Routes.hs
View file

@ -1,18 +1,17 @@
module Routes where module Routes where
import Control.Concurrent.Async qualified as Async
import Control.Logger.Simple qualified as Log
import DB import DB
import Data.Aeson qualified as A import Data.Aeson qualified as A
import Data.Functor ((<&>)) import Data.Functor ((<&>))
import Data.Maybe (maybeToList) import Data.Maybe (maybeToList)
import Data.Text qualified as T
import Fedi qualified as Fedi import Fedi qualified as Fedi
import Html import Html
import Lucid qualified as H import Lucid qualified as H
import Routes.Inbox.Follow
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Web.Twain qualified as Twain import Web.Twain qualified as Twain
import Data.Text qualified as T
import Control.Concurrent.Async qualified as Async
import Control.Logger.Simple qualified as Log
routes :: DB -> FilePath -> [Twain.Middleware] routes :: DB -> FilePath -> [Twain.Middleware]
routes db detailsFile = routes db detailsFile =
@ -47,10 +46,12 @@ routes db detailsFile =
notes <- map noteToCreate <$> liftIO db.getNotes notes <- map noteToCreate <$> liftIO db.getNotes
Fedi.handleCreateNote details notes Fedi.handleCreateNote details notes
, -- Match inbox , -- Match inbox
Twain.post (Fedi.matchInbox $ unsafePerformIO $ fetchUserDetails detailsFile) do Twain.post (Fedi.matchInbox $ unsafePerformIO $ fetchUserDetails detailsFile) do
Log.logTrace "Inbox" Log.logTrace "Inbox"
Fedi.handleInbox (handleInbox db detailsFile) Fedi.handleInbox (handleInbox db detailsFile)
, -- Match Create object , -- Match Create object
Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
details <- liftIO $ fetchUserDetails detailsFile details <- liftIO $ fetchUserDetails detailsFile
@ -72,12 +73,12 @@ routes db detailsFile =
Nothing -> Twain.next Nothing -> Twain.next
Just thenote -> Just thenote ->
Twain.send $ Twain.html $ H.renderBS $ actorPage details [thenote] Twain.send $ Twain.html $ H.renderBS $ actorPage details [thenote]
, -- Followers , -- Followers
Twain.get (Fedi.matchFollowers $ unsafePerformIO $ fetchUserDetails detailsFile) do Twain.get (Fedi.matchFollowers $ unsafePerformIO $ fetchUserDetails detailsFile) do
details <- liftIO $ fetchUserDetails detailsFile details <- liftIO $ fetchUserDetails detailsFile
followers <- followers <- liftIO db.getFollowers
liftIO db.getFollowers <&> map (\follower -> T.unpack follower.actorId)
<&> map (\follower -> T.unpack follower.actorId)
Fedi.handleFollowers details followers Fedi.handleFollowers details followers
, -- Following , -- Following
Twain.get (Fedi.matchFollowing $ unsafePerformIO $ fetchUserDetails detailsFile) do Twain.get (Fedi.matchFollowing $ unsafePerformIO $ fetchUserDetails detailsFile) do
@ -87,8 +88,8 @@ routes db detailsFile =
Twain.get Fedi.matchWebfinger do Twain.get Fedi.matchWebfinger do
details <- liftIO $ fetchUserDetails detailsFile details <- liftIO $ fetchUserDetails detailsFile
Fedi.handleWebfinger details Fedi.handleWebfinger details
, -------------------------------------------------------------------------------------------- --------------------------------------------------------------------------------------------
-- Admin page , -- Admin page
Twain.get (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin") do Twain.get (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin") do
details <- liftIO $ fetchUserDetails detailsFile details <- liftIO $ fetchUserDetails detailsFile
notes <- liftIO db.getNotes notes <- liftIO db.getNotes
@ -129,22 +130,67 @@ noteToCreate note = Fedi.makeCreateNote note
handleInbox :: DB -> FilePath -> Fedi.AnyActivity -> Twain.ResponderM Twain.Response handleInbox :: DB -> FilePath -> Fedi.AnyActivity -> Twain.ResponderM Twain.Response
handleInbox db detailsFile activity = do handleInbox db detailsFile activity = do
details <- liftIO $ fetchUserDetails detailsFile details <- liftIO $ fetchUserDetails detailsFile
Log.logDebug $ "Inbox request: " <> Fedi.pJson activity Log.logDebug (Fedi.pJson activity)
case activity of case activity of
Fedi.ActivityFollow follow -> Fedi.ActivityFollow follow -> do
handleInboxFollow details db activity follow let
id' = follow.id
actor = follow.otype.actor
object = follow.otype.atype.object
case id' of
Just id'' -> do
if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
then do
let
followerEntry = ( FollowerEntry
{ actorId = fromString actor.unwrap
, followId = fromString id''.unwrap
}
)
callback =
( \(insertId :: DB.Int64) -> do
result <- Fedi.sendPost
details
(actor.unwrap <> "/inbox")
( Fedi.makeAccept
follow
(Fedi.actorUrl details <> "/accepts/follows/" <> show insertId)
)
Log.logDebug (Fedi.pShow result)
pure $ Twain.text ""
)
liftIO do
insertFollower db followerEntry callback
<* Log.logInfo ("New follower: " <> Fedi.pShow followerEntry)
else Twain.next
Nothing ->
Twain.next
Fedi.ActivityUndo Fedi.ActivityUndo
( Fedi.Object ( Fedi.Object
{ otype = { otype = Fedi.TypeActivity
Fedi.TypeActivity { atype = Fedi.TypeUndo
{ atype = { object = Fedi.ActivityFollow follow
Fedi.TypeUndo }
{ object = Fedi.ActivityFollow follow
}
}
} }
) -> }) -> do
handleInboxUnfollow details db activity follow let
id' = follow.id
actor = follow.otype.actor
object = follow.otype.atype.object
case id' of
Just id'' -> do
if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
then do
liftIO do
deletedId <- db.deleteFollower FollowerEntry
{ actorId = fromString actor.unwrap
, followId = fromString id''.unwrap
}
Log.logInfo ("deleted follower: " <> Fedi.pShow deletedId)
pure $ Twain.text ""
else Twain.next
Nothing ->
Twain.next
_ -> do _ -> do
Log.logError $ "Unsupported activity: " <> Fedi.pShow activity Log.logError $ "Unsupported activity: " <> Fedi.pShow activity
Twain.next Twain.next

38
app/Routes/Inbox/Accept.hs
View file

@ -1,38 +0,0 @@
module Routes.Inbox.Accept where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async qualified as Async
import Control.Logger.Simple qualified as Log
import DB
import Fedi qualified as Fedi
acceptRequest
:: Fedi.UserDetails
-> Fedi.Link
-> Fedi.AnyActivity
-> ((Int64 -> IO ()) -> IO a)
-> IO ()
acceptRequest details actor activity operation = do
_ <- liftIO $ Async.async do
Log.logDebug "Waiting 10 seconds before accepting follow..."
threadDelay 10000000 -- 10 seconds
let
callback =
( \(opid :: DB.Int64) -> do
result <-
Fedi.sendPost
details
(actor.unwrap <> "/inbox")
( Fedi.makeAccept
Fedi.MkAccept
{ Fedi.acceptId =
Fedi.actorUrl details <> "/accepts/requests/" <> show opid
, Fedi.acceptingActorUrl = Fedi.Link $ Fedi.actorUrl details
, Fedi.acceptedActivity = activity
}
)
Log.logDebug (Fedi.pShow result)
)
do
operation callback
pure ()

80
app/Routes/Inbox/Follow.hs
View file

@ -1,80 +0,0 @@
module Routes.Inbox.Follow where
import Control.Logger.Simple qualified as Log
import DB
import Fedi qualified as Fedi
import Routes.Inbox.Accept
import Web.Twain qualified as Twain
handleInboxFollow
:: Fedi.UserDetails
-> DB
-> Fedi.AnyActivity
-> Fedi.Follow
-> Twain.ResponderM Twain.Response
handleInboxFollow details db activity follow = do
let
id' = follow.id
actor = follow.otype.actor
object = follow.otype.atype.object
case id' of
Just id'' -> do
if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
then do
let
followerEntry =
( FollowerEntry
{ actorId = fromString actor.unwrap
, followId = fromString id''.unwrap
}
)
operation sendAccept = do
insertFollower db followerEntry sendAccept
<* Log.logInfo ("New follower: " <> Fedi.pShow followerEntry)
liftIO $ acceptRequest details actor activity operation
pure $ Twain.text ""
else Twain.next
Nothing ->
Twain.next
handleInboxUnfollow
:: Fedi.UserDetails
-> DB
-> Fedi.AnyActivity
-> Fedi.Follow
-> Twain.ResponderM Twain.Response
handleInboxUnfollow details db activity follow = do
let
id' = follow.id
actor = follow.otype.actor
object = follow.otype.atype.object
case id' of
Just id'' -> do
if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
then do
let
followerEntry =
( FollowerEntry
{ actorId = fromString actor.unwrap
, followId = fromString id''.unwrap
}
)
operation sendAccept = do
deleteFollower
db
followerEntry
( \deletedId' -> do
let
deletedId = Fedi.fromMaybe 0 deletedId'
sendAccept deletedId
<* Log.logInfo ("Deleted follower: " <> Fedi.pShow deletedId)
)
liftIO $ acceptRequest details actor activity operation
pure $ Twain.text ""
else Twain.next
Nothing ->
Twain.next

2
fedi.cabal
View file

@ -91,8 +91,6 @@ executable fedi
Html Html
Css Css
Routes Routes
Routes.Inbox.Follow
Routes.Inbox.Accept
-- other-extensions: -- other-extensions:
build-depends: build-depends:
aeson aeson

2
src/Fedi.hs
View file

@ -2,9 +2,9 @@ module Fedi (module Export) where
import Fedi.Crypto as Export import Fedi.Crypto as Export
import Fedi.Helpers as Export import Fedi.Helpers as Export
import Fedi.Requests as Export
import Fedi.Routes as Export import Fedi.Routes as Export
import Fedi.Types as Export import Fedi.Types as Export
import Fedi.Types.Helpers as Export import Fedi.Types.Helpers as Export
import Fedi.UserDetails as Export import Fedi.UserDetails as Export
import Fedi.Webfinger as Export import Fedi.Webfinger as Export
import Fedi.Requests as Export

42
src/Fedi/Crypto.hs
View file

@ -1,29 +1,27 @@
{-# LANGUAGE RecordWildCards #-} {-# language RecordWildCards #-}
module Fedi.Crypto where module Fedi.Crypto where
import Control.Logger.Simple qualified as Log
import Control.Monad.IO.Class
import Crypto.Hash qualified as Crypto import Crypto.Hash qualified as Crypto
import Crypto.PubKey.RSA.PKCS15 qualified as Crypto
import Crypto.Store.PKCS8 qualified as Crypto
import Crypto.Store.X509 qualified as Crypto
import Data.Base64.Types qualified as Base64
import Data.ByteArray qualified as BA import Data.ByteArray qualified as BA
import Data.ByteString.Base64 qualified as Base64 import Crypto.PubKey.RSA.PKCS15 qualified as Crypto
import Data.Text qualified as T import Crypto.Store.X509 qualified as Crypto
import Crypto.Store.PKCS8 qualified as Crypto
import Data.X509 qualified as Crypto import Data.X509 qualified as Crypto
import Fedi.Helpers import Fedi.Helpers
import Data.ByteString.Base64 qualified as Base64
import Data.Base64.Types qualified as Base64
import Data.Text qualified as T
import Control.Logger.Simple qualified as Log
import Control.Monad.IO.Class
verifyPub :: (MonadIO m) => (MonadThrow m) => ByteString -> ByteString -> ByteString -> m Bool verifyPub :: MonadIO m => MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool
verifyPub pubkeypem sig message = do verifyPub pubkeypem sig message = do
Log.logDebug $ Log.logDebug $ "Verifying signature: " <> pShow
"Verifying signature: " [ ("pubkeypem", pubkeypem)
<> pShow , ("sig", sig)
[ ("pubkeypem", pubkeypem) , ("message", message)
, ("sig", sig) ]
, ("message", message)
]
pubkey <- pubkey <-
case Crypto.readPubKeyFileFromMemory pubkeypem of case Crypto.readPubKeyFileFromMemory pubkeypem of
@ -45,13 +43,13 @@ sign privatePemFile message = do
& either (throw . show) pure & either (throw . show) pure
-- return -- return
pure Signed {..} pure Signed{..}
newtype Signed newtype Signed
= Signed = Signed
{ signedMessage :: ByteString { signedMessage :: ByteString
} }
deriving (Show) deriving Show
ppSigned :: Signed -> String ppSigned :: Signed -> String
ppSigned signed = ppSigned signed =
@ -72,4 +70,4 @@ decodeBase64 = Base64.decodeBase64Lenient
makeDigest :: ByteString -> ByteString makeDigest :: ByteString -> ByteString
makeDigest message = makeDigest message =
BA.convert (Crypto.hash message :: Crypto.Digest Crypto.SHA256) BA.convert (Crypto.hash message :: Crypto.Digest Crypto.SHA256)

37
src/Fedi/Helpers.hs
View file

@ -1,39 +1,40 @@
module Fedi.Helpers ( module Fedi.Helpers
module Export, ( module Export
module Fedi.Helpers, , module Fedi.Helpers
) where )
where
import Control.Monad as Export import Fedi.UserDetails
import Control.Monad.Catch as Export (Exception, MonadThrow, throwM)
import Data.Aeson qualified as A
import Data.Aeson.Encode.Pretty qualified as AP
import Data.ByteString as Export (ByteString)
import Data.Foldable as Export import Data.Foldable as Export
import Data.Function as Export
import Data.Functor as Export
import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList) import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList)
import Data.String as Export (fromString) import Data.String as Export (fromString)
import Data.Text as Export (Text) import Data.Text as Export (Text)
import Data.Text.Lazy qualified as TL import Data.ByteString as Export (ByteString)
import Data.Text.Lazy.Encoding qualified as TL
import Data.Time as Export (UTCTime) import Data.Time as Export (UTCTime)
import Data.Traversable as Export import Data.Traversable as Export
import Fedi.UserDetails
import GHC.Generics as Export (Generic) import GHC.Generics as Export (Generic)
import Control.Monad as Export
import Data.Functor as Export
import Data.Function as Export
import Control.Monad.Catch as Export (throwM, Exception, MonadThrow)
import Text.Pretty.Simple qualified as PS import Text.Pretty.Simple qualified as PS
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TL
import Data.Aeson qualified as A
import Data.Aeson.Encode.Pretty qualified as AP
data Error data Error
= Error String = Error String
deriving (Show, Exception) deriving (Show, Exception)
throw :: (MonadThrow m) => String -> m a throw :: MonadThrow m => String -> m a
throw = throwM . Error throw = throwM . Error
pShow :: (Show a) => a -> Text pShow :: Show a => a -> Text
pShow = TL.toStrict . PS.pShow pShow = TL.toStrict . PS.pShow
pJson :: (A.ToJSON a) => a -> Text pJson :: A.ToJSON a => a -> Text
pJson = pJson =
TL.toStrict TL.toStrict
. TL.decodeUtf8 . TL.decodeUtf8
. AP.encodePretty' AP.defConfig {AP.confIndent = AP.Spaces 2} . AP.encodePretty' AP.defConfig { AP.confIndent = AP.Spaces 2 }

51
src/Fedi/Requests.hs
View file

@ -1,34 +1,33 @@
{-# LANGUAGE DataKinds #-} {-# language DataKinds #-}
module Fedi.Requests where module Fedi.Requests where
import Control.Logger.Simple qualified as Log
import Data.Aeson qualified as A
import Data.ByteString.Lazy qualified as BSL
import Data.List (intercalate) import Data.List (intercalate)
import Data.Text qualified as T import Data.Aeson qualified as A
import Fedi.Helpers import Fedi.Helpers
import Fedi.Signature.Sign
import Fedi.UserDetails import Fedi.UserDetails
import Fedi.Signature.Sign
import Network.HTTP.Req qualified as Req import Network.HTTP.Req qualified as Req
import Data.ByteString.Lazy qualified as BSL
import Text.URI qualified as URI import Text.URI qualified as URI
import Data.Text qualified as T
import Control.Logger.Simple qualified as Log
sendPost sendPost
:: (A.ToJSON input) :: A.ToJSON input
=> UserDetails => UserDetails
-> String -> String
-> input -> input
-> IO ByteString -> IO ByteString
sendPost details url payload = do sendPost details url payload = do
uri <- URI.mkURI $ fromString url uri <- URI.mkURI $ fromString url
Log.logDebug $ "Post To: " <> fromString url Log.logDebug "To: " <> fromString url
Log.logDebug $ "Post Sending: " <> pJson payload Log.logDebug "Sending: " <> pJson payload
let let encoded = BSL.toStrict $ A.encode payload
encoded = BSL.toStrict $ A.encode payload
httpSignature <- makeHttpSignature details uri encoded httpSignature <- makeHttpSignature details uri encoded
Log.logDebug $ "Post http signature: " <> pShow httpSignature Log.logDebug $ "http signature: " <> pShow httpSignature
Log.logDebug $ "Post http signature headers: " <> pShow (makeSigHeaders httpSignature) Log.logDebug $ "http signature headers: " <> pShow (makeSigHeaders httpSignature)
(url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri) (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
Req.runReq Req.defaultHttpConfig do Req.runReq Req.defaultHttpConfig do
response <- response <-
@ -38,13 +37,13 @@ sendPost details url payload = do
(Req.ReqBodyBs encoded) (Req.ReqBodyBs encoded)
Req.bsResponse Req.bsResponse
( scheme ( scheme
<> sigHeaders httpSignature <> sigHeaders httpSignature
) )
( \request -> do (\request -> do
Log.logDebug $ "Sending POST request: " <> pShow request Log.logDebug $ "Sending POST request: " <> pShow request
pure request pure request
) )
Log.logInfo $ "Post Response: " <> pShow response Log.logInfo $ "Response: " <> pShow response
pure $ Req.responseBody response pure $ Req.responseBody response
makeHttpSignature :: UserDetails -> URI.URI -> ByteString -> IO HttpSignature makeHttpSignature :: UserDetails -> URI.URI -> ByteString -> IO HttpSignature
@ -61,6 +60,7 @@ makeHttpSignature details uri encoded = do
Nothing -> "/" Nothing -> "/"
signSignature details host ("post " <> path) encoded signSignature details host ("post " <> path) encoded
sigHeaders :: HttpSignature -> Req.Option scheme sigHeaders :: HttpSignature -> Req.Option scheme
sigHeaders = sigHeaders =
foldMap (uncurry Req.header) . makeSigHeaders foldMap (uncurry Req.header) . makeSigHeaders
@ -75,24 +75,23 @@ makeSigHeaders httpSignature =
, ("Signature", toSignature httpSignature.signatureHeader) , ("Signature", toSignature httpSignature.signatureHeader)
] ]
sendGet :: (Show a, A.FromJSON a) => String -> IO a sendGet :: (A.FromJSON a) => String -> IO a
sendGet url = do sendGet url = do
uri <- URI.mkURI $ fromString url uri <- URI.mkURI $ fromString url
(url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri) (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
Req.runReq Req.defaultHttpConfig do Req.runReq Req.defaultHttpConfig do
response <- r <-
Req.reqCb Req.reqCb
Req.GET Req.GET
url' url'
Req.NoReqBody Req.NoReqBody
Req.jsonResponse Req.jsonResponse
( scheme ( scheme
<> Req.header "ContentType" "application/activity+json" <> Req.header "ContentType" "application/activity+json"
) )
( \request -> do (\request -> do
Log.logDebug $ "Sending GET request: " <> pShow request Log.logDebug $ "Sending GET request: " <> pShow request
pure request pure request
) )
Log.logInfo $ "Get Response: " <> pShow response pure $ Req.responseBody r
pure $ Req.responseBody response

22
src/Fedi/Routes.hs
View file

@ -1,17 +1,19 @@
module Fedi.Routes ( module Fedi.Routes
module Fedi.Routes, ( module Fedi.Routes
module Export, , module Export
) where )
where
import Fedi.Routes.Follow as Export
import Fedi.Routes.Helpers as Export
import Fedi.Routes.Inbox as Export
import Fedi.Routes.Notes as Export
import Fedi.Routes.Outbox as Export
import Fedi.Routes.User as Export
import Fedi.UserDetails import Fedi.UserDetails
import Web.Twain qualified as Twain import Web.Twain qualified as Twain
import Fedi.Routes.Helpers as Export
import Fedi.Routes.User as Export
import Fedi.Routes.Inbox as Export
import Fedi.Routes.Outbox as Export
import Fedi.Routes.Notes as Export
import Fedi.Routes.Follow as Export
-- * Routes -- * Routes
routes :: UserDetails -> [Twain.Middleware] routes :: UserDetails -> [Twain.Middleware]

8
src/Fedi/Routes/Follow.hs
View file

@ -2,10 +2,10 @@ module Fedi.Routes.Follow where
import Data.Aeson qualified as A import Data.Aeson qualified as A
import Fedi.Helpers import Fedi.Helpers
import Fedi.Routes.Helpers
import Fedi.Types import Fedi.Types
import Fedi.Types.Helpers import Fedi.Types.Helpers
import Fedi.UserDetails import Fedi.UserDetails
import Fedi.Routes.Helpers
import Web.Twain qualified as Twain import Web.Twain qualified as Twain
import Web.Twain.Types qualified as Twain import Web.Twain.Types qualified as Twain
@ -79,7 +79,7 @@ handleFollowing details = do
collection :: Collection () collection :: Collection ()
collection = collection =
emptyUnorderedCollection emptyUnorderedCollection
{ id = Just $ ObjectId $ actorUrl details <> "/following" { id = Just $ ObjectId $ actorUrl details <> "/following"
, summary = Just $ fromString $ details.username <> " is following" , summary = Just $ fromString $ details.username <> " is following"
} }
Twain.send $ jsonLD (A.encode collection) Twain.send $ jsonLD (A.encode collection)

2
src/Fedi/Routes/Helpers.hs
View file

@ -1,10 +1,10 @@
module Fedi.Routes.Helpers where module Fedi.Routes.Helpers where
import Control.Monad.Catch (throwM)
import Data.Aeson qualified as A import Data.Aeson qualified as A
import Data.ByteString qualified as BS import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL import Data.ByteString.Lazy qualified as BSL
import Web.Twain qualified as Twain import Web.Twain qualified as Twain
import Control.Monad.Catch (throwM)
jsonLD :: BSL.ByteString -> Twain.Response jsonLD :: BSL.ByteString -> Twain.Response
jsonLD = jsonLD =

10
src/Fedi/Routes/Inbox.hs
View file

@ -1,14 +1,14 @@
module Fedi.Routes.Inbox where module Fedi.Routes.Inbox where
import Control.Logger.Simple qualified as Log import Prelude hiding (error)
import Control.Monad.Catch (SomeException, catch, displayException)
import Fedi.Helpers
import Fedi.Signature.Check
import Fedi.Types import Fedi.Types
import Fedi.Helpers
import Fedi.UserDetails import Fedi.UserDetails
import Web.Twain qualified as Twain import Web.Twain qualified as Twain
import Web.Twain.Types qualified as Twain import Web.Twain.Types qualified as Twain
import Prelude hiding (error) import Control.Monad.Catch (catch, displayException, SomeException)
import Fedi.Signature.Check
import Control.Logger.Simple qualified as Log
-- * Inbox -- * Inbox

2
src/Fedi/Routes/Notes.hs
View file

@ -1,9 +1,9 @@
module Fedi.Routes.Notes where module Fedi.Routes.Notes where
import Data.Aeson qualified as A import Data.Aeson qualified as A
import Fedi.Routes.Helpers
import Fedi.Types import Fedi.Types
import Fedi.UserDetails import Fedi.UserDetails
import Fedi.Routes.Helpers
import Web.Twain qualified as Twain import Web.Twain qualified as Twain
import Web.Twain.Types qualified as Twain import Web.Twain.Types qualified as Twain

2
src/Fedi/Routes/Outbox.hs
View file

@ -2,10 +2,10 @@ module Fedi.Routes.Outbox where
import Data.Aeson qualified as A import Data.Aeson qualified as A
import Fedi.Helpers import Fedi.Helpers
import Fedi.Routes.Helpers
import Fedi.Types import Fedi.Types
import Fedi.Types.Helpers import Fedi.Types.Helpers
import Fedi.UserDetails import Fedi.UserDetails
import Fedi.Routes.Helpers
import Web.Twain qualified as Twain import Web.Twain qualified as Twain
import Web.Twain.Types qualified as Twain import Web.Twain.Types qualified as Twain

4
src/Fedi/Routes/User.hs
View file

@ -2,10 +2,10 @@ module Fedi.Routes.User where
import Data.Aeson qualified as A import Data.Aeson qualified as A
import Fedi.Helpers import Fedi.Helpers
import Fedi.Routes.Helpers
import Fedi.Types.Helpers
import Fedi.UserDetails import Fedi.UserDetails
import Fedi.Webfinger import Fedi.Webfinger
import Fedi.Types.Helpers
import Fedi.Routes.Helpers
import Web.Twain qualified as Twain import Web.Twain qualified as Twain
import Web.Twain.Types qualified as Twain import Web.Twain.Types qualified as Twain

153
src/Fedi/Signature/Check.hs
View file

@ -1,29 +1,30 @@
{-# LANGUAGE RecordWildCards #-} {-# language RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-} {-# language ViewPatterns #-}
module Fedi.Signature.Check ( module Fedi.Signature.Check
module Fedi.Signature.Types, ( module Fedi.Signature.Types
module Fedi.Signature.Check, , module Fedi.Signature.Check
) where )
where
import Control.Monad.IO.Class import Prelude hiding (error)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.CaseInsensitive qualified as CI
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Fedi.Crypto
import Fedi.Helpers
import Fedi.Requests
import Fedi.Routes.Helpers
import Fedi.Signature.Types
import Fedi.Types import Fedi.Types
import Fedi.UserDetails import Fedi.UserDetails
import Network.HTTP.Types.URI qualified as HTTP import Fedi.Requests
import Network.Wai qualified as Wai import Fedi.Routes.Helpers
import Text.ParserCombinators.ReadP qualified as P import Fedi.Helpers
import Web.Twain qualified as Twain import Web.Twain qualified as Twain
import Prelude hiding (error) import Data.Text qualified as T
import Network.Wai qualified as Wai
import Network.HTTP.Types.URI qualified as HTTP
import Text.ParserCombinators.ReadP qualified as P
import Data.Text.Encoding qualified as T
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Fedi.Crypto
import Fedi.Signature.Types
import Data.CaseInsensitive qualified as CI
import Control.Monad.IO.Class
-- * Check -- * Check
@ -35,14 +36,11 @@ checkSignatureAndParseBody = do
-- liftIO $ print ("headers", Twain.requestHeaders request) -- liftIO $ print ("headers", Twain.requestHeaders request)
body <- liftIO (Wai.strictRequestBody request) body <- liftIO (Wai.strictRequestBody request)
sigheader <- parseSignature =<< Twain.header "Signature" sigheader <- parseSignature =<< Twain.header "Signature"
digest <- digest <- Twain.header "Digest" >>=
Twain.header "Digest" maybe (throw "missing header Digest") (pure . T.encodeUtf8)
>>= maybe (throw "missing header Digest") (pure . T.encodeUtf8)
(person :: Person) <- liftIO $ sendGet sigheader.keyId (person :: Person) <- liftIO $ sendGet sigheader.keyId
let let personPkid = person.otype.publicKey.pkid
personPkid = person.otype.publicKey.pkid let personPublicKey = pemToBS person.otype.publicKey.publicKeyPem
let
personPublicKey = pemToBS person.otype.publicKey.publicKeyPem
signatureString <- signatureString <-
makeSignatureString request sigheader.headers makeSignatureString request sigheader.headers
@ -55,45 +53,37 @@ checkSignatureAndParseBody = do
parseJson body parseJson body
makeSignatureString makeSignatureString
:: forall m. (MonadThrow m) => Wai.Request -> [T.Text] -> m ByteString :: forall m. MonadThrow m => Wai.Request -> [T.Text] -> m ByteString
makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do
let let
requestHeaders = Wai.requestHeaders request requestHeaders = Wai.requestHeaders request
method = T.encodeUtf8 $ T.toLower $ T.decodeUtf8 $ Wai.requestMethod request method = T.encodeUtf8 $ T.toLower $ T.decodeUtf8 $ Wai.requestMethod request
path = path = "/" <> T.encodeUtf8 (T.intercalate "/" $ Wai.pathInfo request)
"/" <> HTTP.renderQuery True (Wai.queryString request)
<> T.encodeUtf8 (T.intercalate "/" $ Wai.pathInfo request)
<> HTTP.renderQuery True (Wai.queryString request)
requestTarget = method <> " " <> path requestTarget = method <> " " <> path
let let
mylookup :: ByteString -> m ByteString mylookup :: ByteString -> m ByteString
mylookup header mylookup header
| header == "(request-target)" = | header == "(request-target)" =
pure $ header <> ": " <> requestTarget pure $ header <> ": " <> requestTarget
| header == "host" = do | header == "host" = do
let let result = lookup (CI.mk header) requestHeaders
result = lookup (CI.mk header) requestHeaders case result of
case result of Nothing -> throw $ "Missing header '" <> show header <> "'."
Nothing -> throw $ "Missing header '" <> show header <> "'." Just value -> pure $ header <> ": "
Just value -> <> if ":443" `BS.isSuffixOf` value
pure $ then BS.dropEnd (BS.length ":443") value
header else value
<> ": "
<> if ":443" `BS.isSuffixOf` value
then BS.dropEnd (BS.length ":443") value
else value
| otherwise = do | otherwise = do
let let result = lookup (CI.mk header) requestHeaders
result = lookup (CI.mk header) requestHeaders case result of
case result of Nothing -> throw $ "Missing header '" <> show header <> "'."
Nothing -> throw $ "Missing header '" <> show header <> "'." Just value -> pure $ header <> ": " <> value
Just value -> pure $ header <> ": " <> value
BS.intercalate "\n" <$> traverse mylookup headers BS.intercalate "\n" <$> traverse mylookup headers
checkSignature checkSignature
:: (MonadIO m) :: MonadIO m => MonadThrow m
=> (MonadThrow m)
=> Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> ByteString -> m () => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> ByteString -> m ()
checkSignature personPkid personPublicKey sigheader signatureString digest body = do checkSignature personPkid personPublicKey sigheader signatureString digest body = do
-- check -- check
@ -109,9 +99,9 @@ checkSignature personPkid personPublicKey sigheader signatureString digest body
unless (mydigest == digest) $ unless (mydigest == digest) $
throw "digest verification failed." throw "digest verification failed."
-- todo: check date -- todo: check date
parseSignature :: (MonadThrow m) => Maybe T.Text -> m SignatureHeader parseSignature :: MonadThrow m => Maybe T.Text -> m SignatureHeader
parseSignature minput = do parseSignature minput = do
input <- maybe (throw "no signature.") (pure . T.unpack) minput input <- maybe (throw "no signature.") (pure . T.unpack) minput
case P.readP_to_S parser input of case P.readP_to_S parser input of
@ -123,33 +113,32 @@ parseSignature minput = do
parser = do parser = do
components <- component `P.sepBy` P.char ',' components <- component `P.sepBy` P.char ','
keyId <- lookup' KeyId components keyId <- lookup' KeyId components
headers <- T.split (== ' ') . T.pack <$> lookup' Headers components headers <- T.split (==' ') . T.pack <$> lookup' Headers components
signature <- signature <-
(fromString) ( fromString
<$> lookup' Signature components ) <$> lookup' Signature components
P.eof P.eof
pure SignatureHeader {..} pure SignatureHeader{..}
component = component = P.choice
P.choice [ do
[ do _ <- P.string "keyId="
_ <- P.string "keyId=" url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"')) pure (KeyId, url)
pure (KeyId, url) , do
, do _ <- P.string "headers="
_ <- P.string "headers=" url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"')) pure (Headers, url)
pure (Headers, url) , do
, do _ <- P.string "signature="
_ <- P.string "signature=" url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"')) pure (Signature, url)
pure (Signature, url) , do
, do _ <- P.string "algorithm="
_ <- P.string "algorithm=" alg <- P.between (P.char '\"') (P.char '\"') (P.string "rsa-sha256")
alg <- P.between (P.char '\"') (P.char '\"') (P.string "rsa-sha256") pure (Algorithm, alg)
pure (Algorithm, alg) -- , do
-- , do -- key <- P.munch1 (/= '=')
-- key <- P.munch1 (/= '=') -- _ <- P.char '='
-- _ <- P.char '=' -- value <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
-- value <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"')) -- pure (Other key, value)
-- pure (Other key, value) ]
]

35
src/Fedi/Signature/Sign.hs
View file

@ -1,26 +1,26 @@
{-# LANGUAGE RecordWildCards #-} {-# language RecordWildCards #-}
module Fedi.Signature.Sign ( module Fedi.Signature.Sign
module Fedi.Signature.Types, ( module Fedi.Signature.Types
module Fedi.Signature.Sign, , module Fedi.Signature.Sign
) where )
where
import Data.ByteString qualified as BS
import Data.Time qualified as Time
import Fedi.Crypto
import Fedi.Helpers
import Fedi.Signature.Types
import Fedi.UserDetails
import Prelude hiding (error) import Prelude hiding (error)
import Fedi.UserDetails
import Fedi.Helpers
import Data.ByteString qualified as BS
import Fedi.Crypto
import Data.Time qualified as Time
import Fedi.Signature.Types
-- * Sign -- * Sign
signSignature signSignature
:: UserDetails -> String -> String -> ByteString -> IO HttpSignature :: UserDetails -> String -> String -> ByteString -> IO HttpSignature
signSignature details host requestTarget body = do signSignature details host requestTarget body = do
date <- date <- Time.getCurrentTime
Time.getCurrentTime <&> Time.formatTime Time.defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
<&> Time.formatTime Time.defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
let let
digest = "SHA-256=" <> encodeBase64 (makeDigest body) digest = "SHA-256=" <> encodeBase64 (makeDigest body)
@ -35,15 +35,14 @@ signSignature details host requestTarget body = do
let let
signature = encodeBase64 signed.signedMessage signature = encodeBase64 signed.signedMessage
signatureHeader = SignatureHeader {..} signatureHeader = SignatureHeader{..}
pure HttpSignature {..} pure HttpSignature{..}
makeSignatureString makeSignatureString
:: String -> String -> String -> ByteString -> ByteString :: String -> String -> String -> ByteString -> ByteString
makeSignatureString host requestTarget date digest = makeSignatureString host requestTarget date digest =
BS.intercalate BS.intercalate "\n"
"\n"
[ "(request-target): " <> fromString requestTarget [ "(request-target): " <> fromString requestTarget
, "host: " <> fromString host , "host: " <> fromString host
, "date: " <> fromString date , "date: " <> fromString date

41
src/Fedi/Signature/Types.hs
View file

@ -1,26 +1,25 @@
{-# LANGUAGE RecordWildCards #-} {-# language RecordWildCards #-}
module Fedi.Signature.Types where module Fedi.Signature.Types where
import Data.ByteString qualified as BS import Prelude hiding (error)
import Fedi.UserDetails
import Data.Text qualified as T import Data.Text qualified as T
import Data.Text.Encoding qualified as T import Data.Text.Encoding qualified as T
import Fedi.UserDetails import Data.ByteString qualified as BS
import Prelude hiding (error)
data HttpSignature data HttpSignature
= HttpSignature = HttpSignature
{ signatureHeader :: SignatureHeader { signatureHeader :: SignatureHeader
, date :: String , date :: String
, host :: String , host :: String
, digest :: ByteString , digest :: ByteString
} }
deriving (Show) deriving Show
toSignature :: SignatureHeader -> ByteString toSignature :: SignatureHeader -> ByteString
toSignature sig = toSignature sig =
BS.intercalate BS.intercalate ","
","
[ "keyId=\"" <> fromString sig.keyId <> "\"" [ "keyId=\"" <> fromString sig.keyId <> "\""
, "headers=\"" <> BS.intercalate " " (map T.encodeUtf8 sig.headers) <> "\"" , "headers=\"" <> BS.intercalate " " (map T.encodeUtf8 sig.headers) <> "\""
, "signature=\"" <> sig.signature <> "\"" , "signature=\"" <> sig.signature <> "\""
@ -29,15 +28,15 @@ toSignature sig =
data SignatureHeader data SignatureHeader
= SignatureHeader = SignatureHeader
{ keyId :: Url { -- | Where to get the public key for this actor
-- ^ Where to get the public key for this actor keyId :: Url
, headers :: [T.Text] , -- | Which headers have been sent
-- ^ Which headers have been sent headers :: [T.Text]
, signature :: ByteString , -- | Contains the signature
-- ^ Contains the signature signature :: ByteString
, components :: [(Component, String)] , components :: [(Component, String)]
} }
deriving (Show) deriving Show
data Component data Component
= KeyId = KeyId

9
src/Fedi/Types.hs
View file

@ -48,9 +48,10 @@ instance (ToObject a) => A.ToJSON (Object a) where
instance (ToObject a) => ToObject (Object a) where instance (ToObject a) => ToObject (Object a) where
toObject object = toObject object =
[ "@context" [ "@context"
A..= [ ("https://www.w3.org/ns/activitystreams" :: String) A..=
, ("https://w3id.org/security/v1" :: String) [ ("https://www.w3.org/ns/activitystreams" :: String)
] , ("https://w3id.org/security/v1" :: String)
]
] ]
<> toObject object.otype <> toObject object.otype
<> [ assignment <> [ assignment
@ -347,6 +348,7 @@ instance A.FromJSON TypeUndo where
object <- value A..: "object" object <- value A..: "object"
pure TypeUndo {..} pure TypeUndo {..}
-- --
type Like = Object (TypeActivity TypeLike) type Like = Object (TypeActivity TypeLike)
@ -537,7 +539,6 @@ type Outbox = OrderedCollection AnyActivity
type OutboxPage = OrderedCollectionPage AnyActivity type OutboxPage = OrderedCollectionPage AnyActivity
type Followers = OrderedCollection Url type Followers = OrderedCollection Url
type FollowersPage = OrderedCollectionPage Url type FollowersPage = OrderedCollectionPage Url
data CollectionType t data CollectionType t

22
src/Fedi/Types/Helpers.hs
View file

@ -152,24 +152,16 @@ emptyOrderedCollectionPage url =
} }
} }
data MkAccept makeAccept :: Follow -> Url -> Accept
= MkAccept makeAccept theirFollow myfollowId =
{ acceptId :: String
, acceptingActorUrl :: Link
, acceptedActivity :: AnyActivity
}
makeAccept :: MkAccept -> Object (TypeActivity TypeAccept)
makeAccept accept =
emptyObject emptyObject
{ id = Just $ ObjectId accept.acceptId { id = Just $ ObjectId myfollowId
, otype = , otype =
TypeActivity TypeActivity
{ actor = accept.acceptingActorUrl { actor = theirFollow.otype.actor
, atype = , atype = TypeAccept
TypeAccept { object = ActivityFollow theirFollow
{ object = accept.acceptedActivity }
}
, target = Nothing , target = Nothing
, origin = Nothing , origin = Nothing
} }

2
src/Fedi/UserDetails.hs
View file

@ -4,11 +4,11 @@ module Fedi.UserDetails (
) where ) where
import Data.Aeson qualified as A import Data.Aeson qualified as A
import Data.ByteString as Export (ByteString)
import Data.Foldable as Export import Data.Foldable as Export
import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList) import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList)
import Data.String as Export (fromString) import Data.String as Export (fromString)
import Data.Text as Export (Text) import Data.Text as Export (Text)
import Data.ByteString as Export (ByteString)
import Data.Text qualified as T import Data.Text qualified as T
import Data.Text.Encoding qualified as T import Data.Text.Encoding qualified as T
import Data.Time as Export (UTCTime) import Data.Time as Export (UTCTime)

11
todo.org
View file

@ -1,11 +0,0 @@
* Fedi
** DONE Outbox of notes
** DONE Inbox
** DONE Publish
** DONE HTTP Signatures
** DONE Follow me / Unfollow me
** TODO Test http signature
** TODO Test outbox
** TODO Test inbox + follow
** TODO Like my note
** TODO Reply to notes