This commit is contained in:
me 2024-12-17 10:47:00 +02:00
parent 4abe4d2d7e
commit 0ba3e9646c
23 changed files with 329 additions and 307 deletions

View file

@ -1,22 +1,20 @@
-- needed because of a compiler bug with OverloadedRecordDot:
-- <https://play.haskell.org/saved/Xq0ZFrQi>
{-# language FieldSelectors #-}
{-# LANGUAGE FieldSelectors #-}
-- | Database interaction
module DB
( module DB
, DB.Int64
)
where
module DB (
module DB,
DB.Int64,
) where
import Control.Monad.IO.Class (liftIO)
import Data.Text qualified as T
import Data.Typeable
import Database.Sqlite.Easy qualified as DB
import Fedi
import GHC.Stack (HasCallStack)
import Text.RawString.QQ
import Control.Monad.IO.Class (liftIO)
import Data.Typeable
-----------------------
@ -27,12 +25,14 @@ data DB
{ getNotes :: IO [Note]
, getNote :: DB.Int64 -> IO (Maybe Note)
, insertNote :: NoteEntry -> IO (DB.Int64, Note)
, -- | We use a callback so we can revert if the operation fails.
insertFollower ::
forall a. Typeable a => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
, -- | 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
, insertFollower
:: forall a
. (Typeable a) => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
-- ^ 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]
}
@ -45,14 +45,14 @@ data NoteEntry
, name :: Maybe String
, url :: Maybe Url
}
deriving Show
deriving (Show)
data FollowerEntry
= FollowerEntry
{ followId :: T.Text
, actorId :: T.Text
}
deriving Show
deriving (Show)
data Follower
= Follower
@ -60,7 +60,7 @@ data Follower
, followId :: T.Text
, actorId :: T.Text
}
deriving Show
deriving (Show)
-----------------------
@ -275,6 +275,7 @@ getFollowersSQL url =
|]
, [DB.SQLText $ T.pack url]
)
-----------------------
-- ** Decode row
@ -292,8 +293,9 @@ decodeNoteRow = \case
] ->
let
emptyNote = emptyUserNote $ T.unpack actor
in (noteid,
emptyNote
in
( noteid
, emptyNote
{ id = Just $ ObjectId $ T.unpack noteidurl
, published = Just $ read (T.unpack published)
, attributedTo = Just $ LLink $ Link $ T.unpack actor
@ -312,7 +314,8 @@ decodeNoteRow = \case
{ id = Just $ ObjectId $ T.unpack noteidurl <> "/shares"
}
}
})
}
)
row -> error $ "Couldn't decode row as Note: " <> show row
decodeIntRow :: [DB.SQLData] -> DB.Int64

View file

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

View file

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

View file

@ -1,18 +1,18 @@
module Routes where
import Control.Concurrent.Async qualified as Async
import Control.Logger.Simple qualified as Log
import DB
import Data.Aeson qualified as A
import Data.Functor ((<&>))
import Data.Maybe (maybeToList)
import Data.Text qualified as T
import Fedi qualified as Fedi
import Html
import Lucid qualified as H
import Routes.Inbox.Follow
import System.IO.Unsafe (unsafePerformIO)
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
import Routes.Inbox.Follow
routes :: DB -> FilePath -> [Twain.Middleware]
routes db detailsFile =
@ -47,12 +47,10 @@ routes db detailsFile =
notes <- map noteToCreate <$> liftIO db.getNotes
Fedi.handleCreateNote details notes
, -- Match inbox
Twain.post (Fedi.matchInbox $ unsafePerformIO $ fetchUserDetails detailsFile) do
Log.logTrace "Inbox"
Fedi.handleInbox (handleInbox db detailsFile)
, -- Match Create object
Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
details <- liftIO $ fetchUserDetails detailsFile
@ -74,11 +72,11 @@ routes db detailsFile =
Nothing -> Twain.next
Just thenote ->
Twain.send $ Twain.html $ H.renderBS $ actorPage details [thenote]
, -- Followers
Twain.get (Fedi.matchFollowers $ unsafePerformIO $ fetchUserDetails detailsFile) do
details <- liftIO $ fetchUserDetails detailsFile
followers <- liftIO db.getFollowers
followers <-
liftIO db.getFollowers
<&> map (\follower -> T.unpack follower.actorId)
Fedi.handleFollowers details followers
, -- Following
@ -89,8 +87,8 @@ routes db detailsFile =
Twain.get Fedi.matchWebfinger do
details <- liftIO $ fetchUserDetails detailsFile
Fedi.handleWebfinger details
--------------------------------------------------------------------------------------------
, -- Admin page
, --------------------------------------------------------------------------------------------
-- Admin page
Twain.get (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin") do
details <- liftIO $ fetchUserDetails detailsFile
notes <- liftIO db.getNotes
@ -137,12 +135,15 @@ handleInbox db detailsFile activity = do
handleInboxFollow details db activity follow
Fedi.ActivityUndo
( Fedi.Object
{ otype = Fedi.TypeActivity
{ atype = Fedi.TypeUndo
{ otype =
Fedi.TypeActivity
{ atype =
Fedi.TypeUndo
{ object = Fedi.ActivityFollow follow
}
}
}) ->
}
) ->
handleInboxUnfollow details db activity follow
_ -> do
Log.logError $ "Unsupported activity: " <> Fedi.pShow activity

View file

@ -1,10 +1,10 @@
module Routes.Inbox.Accept where
import DB
import Fedi qualified as Fedi
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
@ -19,10 +19,12 @@ acceptRequest details actor activity operation = do
let
callback =
( \(opid :: DB.Int64) -> do
result <- Fedi.sendPost
result <-
Fedi.sendPost
details
(actor.unwrap <> "/inbox")
( Fedi.makeAccept Fedi.MkAccept
( Fedi.makeAccept
Fedi.MkAccept
{ Fedi.acceptId =
Fedi.actorUrl details <> "/accepts/requests/" <> show opid
, Fedi.acceptingActorUrl = Fedi.Link $ Fedi.actorUrl details

View file

@ -1,10 +1,10 @@
module Routes.Inbox.Follow where
import Control.Logger.Simple qualified as Log
import DB
import Fedi qualified as Fedi
import Web.Twain qualified as Twain
import Control.Logger.Simple qualified as Log
import Routes.Inbox.Accept
import Web.Twain qualified as Twain
handleInboxFollow
:: Fedi.UserDetails
@ -35,9 +35,7 @@ handleInboxFollow details db activity follow = do
liftIO $ acceptRequest details actor activity operation
pure $ Twain.text ""
else Twain.next
Nothing ->
Twain.next
@ -64,9 +62,12 @@ handleInboxUnfollow details db activity follow = do
}
)
operation sendAccept = do
deleteFollower db followerEntry
deleteFollower
db
followerEntry
( \deletedId' -> do
let deletedId = Fedi.fromMaybe 0 deletedId'
let
deletedId = Fedi.fromMaybe 0 deletedId'
sendAccept deletedId
<* Log.logInfo ("Deleted follower: " <> Fedi.pShow deletedId)
)

View file

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

View file

@ -1,23 +1,25 @@
{-# language RecordWildCards #-}
{-# LANGUAGE RecordWildCards #-}
module Fedi.Crypto where
import Crypto.Hash qualified as Crypto
import Data.ByteArray qualified as BA
import Crypto.PubKey.RSA.PKCS15 qualified as Crypto
import Crypto.Store.X509 qualified as Crypto
import Crypto.Store.PKCS8 qualified as Crypto
import Data.X509 qualified as Crypto
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
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.ByteString.Base64 qualified as Base64
import Data.Text qualified as T
import Data.X509 qualified as Crypto
import Fedi.Helpers
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
Log.logDebug $ "Verifying signature: " <> pShow
Log.logDebug $
"Verifying signature: "
<> pShow
[ ("pubkeypem", pubkeypem)
, ("sig", sig)
, ("message", message)
@ -49,7 +51,7 @@ newtype Signed
= Signed
{ signedMessage :: ByteString
}
deriving Show
deriving (Show)
ppSigned :: Signed -> String
ppSigned signed =

View file

@ -1,39 +1,38 @@
module Fedi.Helpers
( module Export
, module Fedi.Helpers
)
where
module Fedi.Helpers (
module Export,
module Fedi.Helpers,
) where
import Fedi.UserDetails
import Control.Monad as Export
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.Function as Export
import Data.Functor as Export
import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList)
import Data.String as Export (fromString)
import Data.Text as Export (Text)
import Data.ByteString as Export (ByteString)
import Data.Time as Export (UTCTime)
import Data.Traversable as Export
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 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
import Data.Time as Export (UTCTime)
import Data.Traversable as Export
import Fedi.UserDetails
import GHC.Generics as Export (Generic)
import Text.Pretty.Simple qualified as PS
data Error
= Error String
deriving (Show, Exception)
throw :: MonadThrow m => String -> m a
throw :: (MonadThrow m) => String -> m a
throw = throwM . Error
pShow :: Show a => a -> Text
pShow :: (Show a) => a -> Text
pShow = TL.toStrict . PS.pShow
pJson :: A.ToJSON a => a -> Text
pJson :: (A.ToJSON a) => a -> Text
pJson =
TL.toStrict
. TL.decodeUtf8

View file

@ -1,20 +1,20 @@
{-# language DataKinds #-}
{-# LANGUAGE DataKinds #-}
module Fedi.Requests where
import Data.List (intercalate)
import Data.Aeson qualified as A
import Fedi.Helpers
import Fedi.UserDetails
import Fedi.Signature.Sign
import Network.HTTP.Req qualified as Req
import Data.ByteString.Lazy qualified as BSL
import Text.URI qualified as URI
import Data.Text qualified as T
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.Text qualified as T
import Fedi.Helpers
import Fedi.Signature.Sign
import Fedi.UserDetails
import Network.HTTP.Req qualified as Req
import Text.URI qualified as URI
sendPost
:: A.ToJSON input
:: (A.ToJSON input)
=> UserDetails
-> String
-> input
@ -24,7 +24,8 @@ sendPost details url payload = do
Log.logDebug $ "Post To: " <> fromString url
Log.logDebug $ "Post Sending: " <> pJson payload
let encoded = BSL.toStrict $ A.encode payload
let
encoded = BSL.toStrict $ A.encode payload
httpSignature <- makeHttpSignature details uri encoded
Log.logDebug $ "Post http signature: " <> pShow httpSignature
Log.logDebug $ "Post http signature headers: " <> pShow (makeSigHeaders httpSignature)
@ -60,7 +61,6 @@ makeHttpSignature details uri encoded = do
Nothing -> "/"
signSignature details host ("post " <> path) encoded
sigHeaders :: HttpSignature -> Req.Option scheme
sigHeaders =
foldMap (uncurry Req.header) . makeSigHeaders

View file

@ -1,19 +1,17 @@
module Fedi.Routes
( module Fedi.Routes
, module Export
)
where
module Fedi.Routes (
module Fedi.Routes,
module Export,
) 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 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 :: UserDetails -> [Twain.Middleware]

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -1,30 +1,29 @@
{-# language RecordWildCards #-}
{-# language ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Fedi.Signature.Check
( module Fedi.Signature.Types
, module Fedi.Signature.Check
)
where
module Fedi.Signature.Check (
module Fedi.Signature.Types,
module Fedi.Signature.Check,
) where
import Prelude hiding (error)
import Fedi.Types
import Fedi.UserDetails
import Fedi.Requests
import Fedi.Routes.Helpers
import Fedi.Helpers
import Web.Twain qualified as Twain
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 Control.Monad.IO.Class
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
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.UserDetails
import Network.HTTP.Types.URI qualified as HTTP
import Network.Wai qualified as Wai
import Text.ParserCombinators.ReadP qualified as P
import Web.Twain qualified as Twain
import Prelude hiding (error)
-- * Check
@ -36,11 +35,14 @@ checkSignatureAndParseBody = do
-- liftIO $ print ("headers", Twain.requestHeaders request)
body <- liftIO (Wai.strictRequestBody request)
sigheader <- parseSignature =<< Twain.header "Signature"
digest <- Twain.header "Digest" >>=
maybe (throw "missing header Digest") (pure . T.encodeUtf8)
digest <-
Twain.header "Digest"
>>= maybe (throw "missing header Digest") (pure . T.encodeUtf8)
(person :: Person) <- liftIO $ sendGet sigheader.keyId
let personPkid = person.otype.publicKey.pkid
let personPublicKey = pemToBS person.otype.publicKey.publicKeyPem
let
personPkid = person.otype.publicKey.pkid
let
personPublicKey = pemToBS person.otype.publicKey.publicKeyPem
signatureString <-
makeSignatureString request sigheader.headers
@ -53,12 +55,14 @@ checkSignatureAndParseBody = do
parseJson body
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
let
requestHeaders = Wai.requestHeaders request
method = T.encodeUtf8 $ T.toLower $ T.decodeUtf8 $ Wai.requestMethod request
path = "/" <> T.encodeUtf8 (T.intercalate "/" $ Wai.pathInfo request)
path =
"/"
<> T.encodeUtf8 (T.intercalate "/" $ Wai.pathInfo request)
<> HTTP.renderQuery True (Wai.queryString request)
requestTarget = method <> " " <> path
let
@ -67,15 +71,20 @@ makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do
| header == "(request-target)" =
pure $ header <> ": " <> requestTarget
| header == "host" = do
let result = lookup (CI.mk header) requestHeaders
let
result = lookup (CI.mk header) requestHeaders
case result of
Nothing -> throw $ "Missing header '" <> show header <> "'."
Just value -> pure $ header <> ": "
Just value ->
pure $
header
<> ": "
<> if ":443" `BS.isSuffixOf` value
then BS.dropEnd (BS.length ":443") value
else value
| otherwise = do
let result = lookup (CI.mk header) requestHeaders
let
result = lookup (CI.mk header) requestHeaders
case result of
Nothing -> throw $ "Missing header '" <> show header <> "'."
Just value -> pure $ header <> ": " <> value
@ -83,7 +92,8 @@ makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do
BS.intercalate "\n" <$> traverse mylookup headers
checkSignature
:: MonadIO m => MonadThrow m
:: (MonadIO m)
=> (MonadThrow m)
=> Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> ByteString -> m ()
checkSignature personPkid personPublicKey sigheader signatureString digest body = do
-- check
@ -101,7 +111,7 @@ checkSignature personPkid personPublicKey sigheader signatureString digest body
-- todo: check date
parseSignature :: MonadThrow m => Maybe T.Text -> m SignatureHeader
parseSignature :: (MonadThrow m) => Maybe T.Text -> m SignatureHeader
parseSignature minput = do
input <- maybe (throw "no signature.") (pure . T.unpack) minput
case P.readP_to_S parser input of
@ -115,11 +125,12 @@ parseSignature minput = do
keyId <- lookup' KeyId components
headers <- T.split (== ' ') . T.pack <$> lookup' Headers components
signature <-
( fromString
) <$> lookup' Signature components
(fromString)
<$> lookup' Signature components
P.eof
pure SignatureHeader {..}
component = P.choice
component =
P.choice
[ do
_ <- P.string "keyId="
url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))

View file

@ -1,25 +1,25 @@
{-# language RecordWildCards #-}
{-# LANGUAGE RecordWildCards #-}
module Fedi.Signature.Sign
( module Fedi.Signature.Types
, module Fedi.Signature.Sign
)
where
module Fedi.Signature.Sign (
module Fedi.Signature.Types,
module Fedi.Signature.Sign,
) where
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.Crypto
import Fedi.Helpers
import Fedi.Signature.Types
import Fedi.UserDetails
import Prelude hiding (error)
-- * Sign
signSignature
:: UserDetails -> String -> String -> ByteString -> IO HttpSignature
signSignature details host requestTarget body = do
date <- Time.getCurrentTime
date <-
Time.getCurrentTime
<&> Time.formatTime Time.defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
let
@ -42,7 +42,8 @@ signSignature details host requestTarget body = do
makeSignatureString
:: String -> String -> String -> ByteString -> ByteString
makeSignatureString host requestTarget date digest =
BS.intercalate "\n"
BS.intercalate
"\n"
[ "(request-target): " <> fromString requestTarget
, "host: " <> fromString host
, "date: " <> fromString date

View file

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

View file

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

View file

@ -166,7 +166,8 @@ makeAccept accept =
, otype =
TypeActivity
{ actor = accept.acceptingActorUrl
, atype = TypeAccept
, atype =
TypeAccept
{ object = accept.acceptedActivity
}
, target = Nothing

View file

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