ez/ActivityPuppy - Change XXPS2UOWSWD2YXHHY2IDBR6KJ7WGG7XNTSLWUDCIF5CAP2EIAJNQC

Initial change

Created by ez on August 19, 2023

XXPS2UOWSWD2YXHHY2IDBR6KJ7WGG7XNTSLWUDCIF5CAP2EIAJNQC

Dependencies

[2] FOLMCE3LPGVMWZ6IGNQCCFO33F4K3RK5N7XWBKYXVENT5I4QKVCQC

In channels

main

Change contents

File addition: test (d--x------)
[2.1]

File addition: testKey (----------)

[0.1]

File addition: Spec.hs (----------)

[0.1]

import Test.Hspec
import qualified Signatures
main :: IO ()
main = hspec $ do
  Signatures.spec

File addition: Signatures.hs (----------)

[0.1]

-- | Tests HTTP signatures.
module Signatures (spec) where
import Data.Time (UTCTime (..))
import Effectful
import Effectful.Fail (runFailIO)
import Puppy.Crypto.RSA (readKeyFile)
import Puppy.Protocol.ActivityStreams (Id (..))
import Puppy.Protocol.HTTP.Signature
import Test.Hspec
-- TODO: Make tests with official test suite https://github.com/w3c-ccg/http-signatures-test-suite
spec :: Spec
spec = do
  let unwrap :: Either String a -> IO a
      unwrap = either fail pure
  it "generates a valid HTTP signature" $ do
    -- Test case validated through https://dinochiesa.github.io/httpsig/
    testKey <- runEff $ runFailIO $ readKeyFile "test/testKey"
    let date   = UTCTime (read "2137-12-13") 0
        params = GET { host = "example.com", path = "/.well-known/fwibble", date }
        signer = Signer (Id "https://example.com/key") testKey
    sig <- unwrap (makeSignature signer params)
    fmtSignature sig `shouldBe` "keyId=\"https://example.com/key\", algorithm=\"rsa-sha256\", headers=\"(request-target) date host\", signature=\"fafUl+kuJItuFlrqRpzfqAB9Dxf/eLZY6i/jUBlME7nSb4ZRZ6EM0/3/wY1F+JThCUxJTNlW1/tnLzvB4lY33sEFjFQhCe6dKhLL8a3crMec0PDhRADW3kmivzGV+e4snMUG8R9+gQECzaBFSYpB1BE+yVYHHaBiHpqok7P35yEJ9ZJicaOT4bhv8nCMzVau8lj6e2nJra9ucGqIph5sX0wMVxwzlt4rlKUctFsvyjqNKI2Os/OwTrV1VhcvylXiUxWWztJiguQf9wOLgCG1G3O4PKpbinJ7bLkKqSSPJZUeWhCmHNhMYLXBEg0NR7OnDSOAHaNJ3/83EYhY1G3YlmJZ2SZnaGFqUVVySKec2IkbWCzoMeuxLYP16jcQvBU/sCiuSnBQTpdUh0uZsk75+HDz9uFosi8j/e+FZxKEk1ljWt6osUqq/jLjVKPecYBnUSNkhjEUPv4K/UnaV2uLtRvBfqiF/5nKLDtTp/rRdaDxQCdVTGnryVJ0lqsjgZ06SmRuqNJQf274OoEZJSQixulji+0ikpXBp/PeoFnfipEcSC68sKokAFAs9WjF8kq3CsoxkyQsMLziQTSalSseGJP107H7Pqw1fNlaR4zGL8lJo+TNHS4gkKglaMjfoAEMGZKziOQ/vCbvFFIsSqvbuvlF5hRmP1EvNb/mHvr3YJxIuznRkTshMSQ86L+307bxgN7+/05RPWVbWi3FZ5fEKmf8zR7pI2KqY6xdYIV93Cn1AVOLNluHluzd3p2fnlxp2iPu33hB1p1O6xvrE/p5sAA79h+S0f5N2P1bt2jIMGMv345IF6Ra68ep646eNXgyrVNgp2ke+oDdemCzFSDp5Dxsw/16MUbESpwMXPpwRuxD+LdNRrNQFxTIXxrDC2/4LlcEWNGbEOGR2K/xVp3ObZfFYWstX9qOLBsVUCZPOCBHbKKECq81539ePuHm++3A9UNUy8hIfvldRd9Hy977invihhMl77Y699mrcf1zyrES0XNyYsmhlqWJBkO/ELpzL3h28wiL90WhZXNlo/t4U2RDA2b6iQhepDZgqtX9RiLFEhdi7lMYMKSEJc3T7Ia0IuW98eJwYeFL9/2t//BLXUe7ASfLL9nrlcWbBbgQ2CEpQXiO78ypllWf8l03Ki+GT/ptLj1nZSeSMvuLYYwDPEwiw/7Sc3JTnNxhcZVG70f1GjRbLJTI+VdydAbhtdKk6IB/yH57+Q/r/NJof+bmHb+FOD5Z8EQql3MQAQ8zfuaQra2XklH2DgfwMun3++fvh4uAfFUSKbBywHgmzKIVDw1HB9NRx4WfRNlXFVzK5BWAsmM9hHASC4w7vV9wWL19ayGvi7aOALgsHeWCacyOaw==\""

File addition: src (d--x------)
[2.1]
File addition: lib (d--x------)
[0.9039]
File addition: Puppy (d--x------)
[0.9056]

File addition: Types.hs (----------)

[0.9073]

{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE StrictData       #-}
-- | Internal data types for representing local data in the database.
module Puppy.Types (
  Channel (..),
  Post (..),
  User (..),
  ChannelSettings (..)
) where
import Data.UUID (UUID)
import Data.Text (Text)
import qualified Crypto.PubKey.RSA as RSA
data User
  = User {
    userId      :: UUID,
    userName    :: Text,
    mainChannel :: UUID
  }
data Channel
  = Channel {
    channelId     :: UUID,
    linkedActorId :: Text,
    privateKeyPem :: RSA.PrivateKey,
    settings      :: ChannelSettings
  }
data Post
  = Post {
    postId           :: UUID,
    linkedDocumentId :: Text
  }
data ChannelSettings
  = ChannelSettings {
    autoAcceptFollows :: Bool
  }

File addition: TaskQueue.hs (----------)

[0.9073]

{-# LANGUAGE TemplateHaskell #-}
-- | An effect for {en,de}queueing tasks of a particular type
-- through concurrent channels.
module Puppy.TaskQueue (
  -- * A basic effect for talking to other threads
  TaskQueue,
  enqueue,
  dequeue,
  runTaskQueue,
  -- * Task types
  PerformTask (..),
  DeliverTask (..),
) where
import Effectful
import Effectful.Concurrent.Chan
import Effectful.Dispatch.Dynamic
import Effectful.TH (makeEffect)
import Puppy.Types (Channel)
import qualified Puppy.Protocol.ActivityStreams as AS
-- | Schedule work through a task queue.
data TaskQueue work :: Effect where
  Enqueue :: work -> TaskQueue work m ()
  Dequeue :: TaskQueue work m work
makeEffect ''TaskQueue
runTaskQueue
  :: (Concurrent :> es)
  => Chan task
  -> Eff (TaskQueue task : es) a
  -> Eff es a
runTaskQueue chan = interpret $ \_ -> \case
  Enqueue v -> writeChan chan v
  Dequeue -> readChan chan
data PerformTask
  = PerformTask (AS.Activity AS.Object) Channel
data DeliverTask
  = DeliverTask (AS.Activity AS.Object) Channel

File addition: Protocol (d--x------)
[0.9073]

File addition: WebFinger.hs (----------)

[0.10950]

{-# LANGUAGE DerivingStrategies #-}
-- | Code and utilities related to the WebFinger protocol.
module Puppy.Protocol.WebFinger (
  JRD,
  Handle (..),
  parseHandle,
  lookupLocal,
  queryRemote,
) where
import Data.Aeson ((.=))
import Data.Text (Text)
import Effectful
import Puppy.Logging
import qualified Data.Aeson as JSON
import qualified Data.Text as T
-- | A JSON Resource Descriptor.
newtype JRD = JRD JSON.Value
  deriving newtype (JSON.FromJSON, JSON.ToJSON)
data Handle
  = Handle { actorName :: Text, nodeName :: Text }
parseHandle :: Text -> Maybe Handle
parseHandle = check . build . preprocess
  where
    check h = case h of
      Handle "" _ -> Nothing
      Handle _ "" -> Nothing
      handle -> Just handle
    preprocess = T.dropWhile (== '@') 
    build = Handle
      <$> T.takeWhile (/= '@')
      <*> T.takeWhileEnd (/= '@')
lookupLocal 
  :: (Log :> es) 
  => Handle 
  -> Eff es (Maybe JRD)
lookupLocal (Handle actorName nodeName) = scope "lookupLocal" $ do
  pure (Just $ JRD $ JSON.object [
    "subject" .= JSON.String ("acct:" <> actorName <> "@" <> nodeName),
    "links" .= [JSON.object [
        "rel"  .= JSON.String "self",
        "type" .= JSON.String "application/activity+json",
        "href" .= JSON.String ("https://" <> nodeName <> "/ap/a/" <> actorName)
      ]]
    ])
queryRemote :: Handle -> Eff es (Maybe JRD)
queryRemote = undefined

File addition: HTTP.hs (----------)

[0.10950]

module Puppy.Protocol.HTTP (
  HTTP,
  get,
  post,
  setKey,
  Response (..),
  runHTTP
) where
import Control.Exception (catch)
import Control.Monad (when)
import Data.Functor ((<&>))
import Data.Maybe (fromJust)
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Fail (Fail)
import Effectful.Reader.Static (Reader, ask, runReader, local)
import Network.HTTP.Conduit (httpLbs, responseBody, Manager, Request (..), RequestBody (RequestBodyBS), responseStatus, parseRequest, HttpException)
import Puppy.Config (version)
import Puppy.Logging
import qualified Data.Aeson                    as JSON
import qualified Data.ByteString               as BS
import qualified Data.ByteString.Lazy          as LBS
import qualified Data.Text                     as T
import qualified Data.Text.Encoding            as T
import qualified Puppy.Protocol.HTTP.Signature as S
data Response
  = Response {
    statusCode :: Int,
    body :: BS.ByteString
  }
-- * Effect
-- | An effect for performing actions related to the HTTP protocol, such as executing
-- requests.
data HTTP :: Effect where
  SetKey :: S.Signer -> m a -> HTTP m a
  Post   :: LBS.ByteString -> Text -> HTTP m Response
  Get    :: Text -> HTTP m Response
type instance DispatchOf HTTP = 'Dynamic
-- * Actions
-- | POST a JSON payload to a URL.
post :: (HTTP :> es, JSON.ToJSON body) => body -> Text -> Eff es Response
post body = send . Post (JSON.encode body)
-- | GET a response from a URL.
get :: (HTTP :> es) => Text -> Eff es Response
get = send . Get
setKey :: (S.KeySource s, HTTP :> es) => s -> Eff es a -> Eff es a
setKey key rest = send (SetKey (S.toSigner key) rest)
-- * Handlers
runHTTP
  :: (IOE :> es, Log :> es, Fail :> es, Reader Manager :> es)
  => (S.KeySource k)
  => k
  -> Eff (HTTP : es) a
  -> Eff es a
runHTTP src = reinterpret (runReader (S.toSigner src)) $ \env -> \case
  SetKey key rest -> localSeqUnlift env $ \unlift ->
    local (const key) (unlift rest)
  Post payload url -> do
    signer <- ask
    req <- withSeqEffToIO (parse url)
    ask >>= execute signer
      (req { method = "POST" })
      (Just $ BS.toStrict payload)
  Get url -> do
    signer <- ask
    req <- withSeqEffToIO (parse url)
    ask >>= execute signer req Nothing
  where 
    parse :: (IOE :> xs, Fail :> xs)
          => Text
          -> (forall r. Eff xs r -> IO r)
          -> IO Request
    parse url unlift = catch
      (parseRequest (T.unpack url))
      (\(exc :: HttpException) -> unlift (fail ("HTTP exception: " <> show exc)))
      
-- * Helpers
-- Actually execute an HTTP request.
execute
  :: (IOE :> es, Log :> es, Fail :> es)
  => S.Signer
  -> Request
  -- ^ URL
  -> Maybe BS.ByteString
  -- ^ Request body
  -> Manager
  -- ^ HTTP client
  -> Eff es Response
execute signer raw body client = do
  now <- liftIO getCurrentTime
  let attachBody r bytes = r {
         requestBody = RequestBodyBS bytes,
         requestHeaders = [
           ("content-type", "application/activity+json"),
           ("digest", S.makeDigestHeader bytes)
         ]
       }
      unsigned | Nothing <- body = raw
               | Just bytes <- body = raw `attachBody` bytes
      -- Propagate a failure
      unwrap = either fail pure
      mkParams | "POST" <- raw.method = S.POST (fromJust body)
               | otherwise = S.GET
      params = mkParams raw.host raw.path now
  req <- unwrap $ S.makeSignature signer params <&> \sig ->
    (unsigned {
      requestHeaders
        = ("accept", "application/activity+json")
        : ("date", S.fmtDateHeader now)
        : ("signature", S.fmtSignature sig)
        : ("user-agent", "ActivityPuppy/" <> version)
        : unsigned.requestHeaders
    })
  res <- httpLbs req client
  when (fromEnum (responseStatus res) `elem` [400 .. 599]) $ do
    warn ("Error response code: " <> T.pack (show (responseStatus res)))
    debug ("Error response body: " <> T.decodeUtf8 (BS.toStrict (responseBody res)))
  return (Response {
    body = BS.toStrict (responseBody res),
    statusCode = fromEnum (responseStatus res)
  })

File addition: HTTP (d--x------)
[0.10950]

File addition: Signature.hs (----------)

[0.16568]

{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors      #-}
{-# LANGUAGE StrictData            #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
-- | Implementation of the HTTP Signatures specification for providing cryptographic
-- authentication of network requests.
module Puppy.Protocol.HTTP.Signature (
  KeySource (..),
  makeSignature,
  makeDigestHeader,
  fmtDateHeader,
  fmtSignature,
  Server (..),
  Signer (..),
  Signature (..),
  Algorithm (..),
  Request (..),
) where
import Crypto.Hash.Algorithms (SHA256(..))
import Data.Bifunctor (Bifunctor(..))
import Data.ByteString.Base64 (encodeBase64)
import Data.Foldable (Foldable(..))
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.List (intersperse)
import Data.String (IsString (..))
import Data.Time.Format
import Data.Time (UTCTime)
import Puppy.Config (ServerConfig (..))
import Puppy.Crypto
import Puppy.Protocol.ActivityStreams (Id (..))
import Puppy.Types (Channel (..))
import qualified Crypto.PubKey.RSA        as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as PKCS15
import qualified Data.ByteString          as BS
import qualified Data.Text                as T
import qualified Data.Text.Encoding       as T
-- | A simplified representation of a network request containing *just* the information
-- we need to generate a signature header.
data Request
  = POST {
    body :: BS.ByteString,
    host :: BS.ByteString,
    path :: BS.ByteString,
    date :: UTCTime
  }
  | GET {
    host :: BS.ByteString,
    path :: BS.ByteString,
    date :: UTCTime
  }
-- | The result of signing a `Request`. Use `fmtSignature` to turn it into a header value.
data Signature
  = Signature {
    -- | Where can we find the public key?
    keyId :: Id,
    -- | The signing algorithm used to construct the signature
    algorithm :: Algorithm,
    -- | The names of the components of the signing string
    components :: [BS.ByteString],
    -- | Base64-encoded cryptographic signature
    signature :: T.Text
  }
data Algorithm
  = RSA_SHA256
  | HS2019
instance Show Algorithm where
  show RSA_SHA256 = "rsa-sha256"
  show HS2019     = "hs2019"
makeSignature :: Signer -> Request -> Either String Signature
makeSignature (Signer { privateKey, keyId }) req =
  let -- Components that are used either way
      common = [ ("(request-target)", fmtTarget req),
                 ("date", fmtDateHeader req.date),
                 ("host", req.host) ]
      -- The final set of components.
      components
        -- In the case of a POST request, many implementations require a digest of
        -- the request body to be included in the signature string.
        | POST { body } <- req = common <> [("digest", makeDigestHeader body)]
        -- In any other case, signing extra stuff is not required.
        | otherwise = common
  in generateSignature components privateKey keyId
     -- `first` converts the RSA error to a string to satisfy the API
     & first show
  where
    fmtTarget (POST { path }) = "post " <> path
    fmtTarget (GET { path })  = "get " <> path
generateSignature
  :: [(BS.ByteString, BS.ByteString)]
  -> RSA.PrivateKey
  -> Id
  -> Either RSA.Error Signature
generateSignature components key keyId =
  let -- This is the string we're gonna end up signing. Every component needs to be
      -- lowercased and separated by newlines.
      signatureString :: BS.ByteString
      signatureString = [ fold [k, ": ", v] | (k,v) <- components ]
          & intersperse "\n"
          & fold
      sign = PKCS15.sign
        Nothing       -- The blinder, empty here because it's not needed (afaik)
        (Just SHA256) -- Hashing algorithm, SHA-256 should be pretty widely supported
        key
        signatureString
      structure signature = Signature { signature, algorithm = RSA_SHA256, components = map fst components, keyId }
  in sign <&> encodeBase64
          <&> structure
makeDigestHeader :: BS.ByteString -> BS.ByteString
makeDigestHeader = ("sha-256=" <>) . base64 . sha256
-- | Format a date header from a time.
fmtDateHeader :: UTCTime -> BS.ByteString
fmtDateHeader now -- RFC-822 formatting, forcing GMT time zone
  = formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" now
  & T.pack
  & T.encodeUtf8
-- | Format an HTTP signature so it can be stuck in a header
fmtSignature :: Signature -> BS.ByteString
fmtSignature sig =
  -- Note: we use `show` here because it adds the quotes around each `show`n
  -- component, which is what we want here.
  fromString $ fold $ intersperse ", " [
    "keyId="     <> show sig.keyId.url,
    "algorithm=" <> show (show sig.algorithm),
    "headers="   <> show (fold $ intersperse " " sig.components),
    "signature=" <> show sig.signature
  ]
class KeySource s where
  toSigner :: s -> Signer
data Signer
  = Signer {
    keyId :: Id,
    privateKey :: RSA.PrivateKey
  }
newtype Server = Server ServerConfig
instance KeySource Server where
  toSigner (Server c) = Signer {
    keyId = Id ("https://" <> c.name <> "/ap/a/server#key"),
    privateKey = c.serverKey
  }
instance KeySource Channel where
  toSigner c = Signer {
    keyId = Id (c.linkedActorId <> "#key"),
    privateKey = c.privateKeyPem
  }
instance KeySource Signer where
  toSigner = id

File addition: ActivityStreams.hs (----------)

[0.10950]

{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors      #-}
{-# LANGUAGE StrictData            #-}
-- | An incomplete-but-good-enough implementation of the ActivityStreams vocabulary.
--
-- This module contains only what is needed for the ActivityPub implementation (which
-- is also technically incomplete).
module Puppy.Protocol.ActivityStreams (
  Activity (..),
  Actor (..),
  Document (..),
  Id (..),
  Inbox (..),
  Object,
  PublicKey (..),
  Subtype (..),
  IsObject (..),
  idToInbox,
  inboxToId,
  object,
  subtype,
) where
import Data.Aeson (FromJSON, ToJSON (..), (.=))
import Data.Functor ((<&>), ($>))
import Data.Maybe (fromMaybe)
import Data.String (IsString)
import Data.Text (Text)
import Data.Time (UTCTime)
import GHC.Generics (Generic)
import GHC.Records (HasField (..))
import Puppy.Crypto.RSA (encodePublicKey)
import qualified Crypto.PubKey.RSA as RSA
import qualified Data.Aeson.Types as JSON
import qualified Data.Text.Encoding as T
import qualified Data.Vector as Vec
import Unsafe.Coerce (unsafeCoerce)
newtype Id = Id { url :: Text }
  deriving newtype (Eq, IsString, ToJSON, FromJSON)
newtype Inbox = Inbox { url :: Text }
  deriving newtype (Eq, IsString, ToJSON, FromJSON)
inboxToId :: Inbox -> Id
inboxToId = Id . (.url)
idToInbox :: Id -> Inbox
idToInbox = Inbox . (.url)
data Activity o
  = Activity {
    id      :: Id,
    actor   :: Id,
    object  :: o,
    to      :: [Inbox],
    cc      :: [Inbox],
    time    :: Maybe UTCTime,
    subtype :: Subtype (Activity o)
  }
instance Functor Activity where
  fmap f x = x { object = f x.object, subtype = unsafeCoerce x.subtype }
data Document
  = Document {
    id      :: Id,
    content :: Maybe Text,
    summary :: Maybe Text,
    subtype :: Subtype Document
  }
data Actor
  = Actor {
    id          :: Id,
    inbox       :: Maybe Inbox,
    outbox      :: Maybe Id,
    followers   :: Maybe Id,
    following   :: Maybe Id,
    accountName :: Text,
    displayName :: Maybe Text,
    summary     :: Maybe Text,
    publicKey   :: PublicKey,
    locked      :: Bool,
    subtype     :: Subtype Actor
  }
data PublicKey
  = PublicKey {
    id           :: Id,
    owner        :: Id,
    publicKeyPem :: RSA.PublicKey
  }
data Object
  = ActivityO (Activity Object)
  | DocumentO Document
  | ActorO    Actor
class IsObject x where 
  toObject   :: x -> Object
  fromObject :: Object -> Maybe x
instance (IsObject o) => IsObject (Activity o) where
  toObject x = ActivityO (x <&> toObject)
  fromObject = \case 
    (ActivityO x) -> (fromObject x.object) <&> (x $>)
    _ -> Nothing
instance IsObject Actor where
  toObject = ActorO
  fromObject = \case
    ActorO o -> Just o
    _ -> Nothing
instance IsObject Document where
  toObject = DocumentO
  fromObject = \case
    DocumentO o -> Just o
    _ -> Nothing
instance IsObject Object where
  toObject = id
  fromObject = pure
-- * Subtyping
class Subtyped a where
  data Subtype a
  subtype :: a -> Subtype a
instance forall o. Subtyped (Activity o) where
  subtype = (.subtype)
  data Subtype (Activity o)
    = Follow
    | Accept
    | Reject
    | Create
    | Delete
    | Announce
    | Like
    | Undo
    deriving (Show, Generic, FromJSON, ToJSON)
instance Subtyped Document where
  subtype = (.subtype)
  data Subtype Document
    = Article
    | Audio
    | Video
    | Image
    | Note
    deriving (Show, Generic, FromJSON, ToJSON)
instance Subtyped Actor where
  subtype = (.subtype)
  data Subtype Actor
    = Person
    | Service
    | Application
    | Organization
    | Group
    deriving (Show, Generic, FromJSON, ToJSON)
instance Subtyped Object where
  subtype = \case
    ActivityO o -> ActivityT o.subtype
    DocumentO o -> DocumentT o.subtype
    ActorO o    -> ActorT o.subtype
  data Subtype Object
    = ActivityT (Subtype (Activity Object))
    | DocumentT (Subtype Document)
    | ActorT (Subtype Actor)
    deriving (Show)
instance HasField "id" Object Id where 
  getField = object (.id) (.id) (.id)
instance (ToJSON o) => ToJSON (Activity o) where
  toJSON o = JSON.object (filterNull [
      "@context"  .= context,
      "id"        .= o.id,
      "to"        .= o.to,
      "cc"        .= o.cc,
      "actor"     .= o.actor,
      "object"    .= o.object,
      "published" .= o.time,
      "type"      .= o.subtype
    ])
instance ToJSON Document where
  toJSON o = JSON.object (filterNull [
      "@context"  .= context,
      "id"      .= o.id,
      "summary" .= o.summary,
      "content" .= o.content,
      "type"    .= o.subtype
    ])
instance ToJSON Actor where
  toJSON o = JSON.object (filterNull [
      "@context"  .= context,
      "id"        .= o.id,
      "inbox"     .= o.inbox,
      "outbox"    .= o.outbox,
      "followers" .= o.followers,
      "following" .= o.following,
      "publicKey" .= o.publicKey,
      "name"      .= fromMaybe o.accountName o.displayName,
      "summary"   .= o.summary,
      "type"      .= o.subtype,
      "preferredUsername"
        .= o.accountName,
      "manuallyApprovesFollowers"
        .= o.locked
    ])
instance ToJSON PublicKey where
  toJSON o = JSON.object [
      "id"           .= o.id,
      "publicKeyPem" .= T.decodeUtf8 (encodePublicKey o.publicKeyPem),
      "owner"        .= o.owner
    ]
instance ToJSON Object where
  toJSON = object toJSON toJSON toJSON
filterNull :: [JSON.Pair] -> [JSON.Pair]
filterNull = filter isNotNull
  where
    isNotNull (_, JSON.Null) = False
    isNotNull _ = True
-- | Case analysis on an `Object`.
object :: (Activity Object -> a) -> (Document -> a) -> (Actor -> a) -> Object -> a
object activity document actor = \case
  ActivityO x -> activity x
  DocumentO x -> document x
  ActorO x -> actor x
context :: JSON.Value
context = JSON.Array (Vec.fromList [
    JSON.String "https://www.w3.org/ns/activitystreams"
  ])

File addition: ActivityPub.hs (----------)

[0.10950]

{-# LANGUAGE DisambiguateRecordFields #-}
-- | Exposes an effect for actions involving the ActivityPub protocol.
module Puppy.Protocol.ActivityPub (
  module Puppy.Protocol.ActivityStreams,
  ActivityPub,
  runActivityPub,
  dereference,
  perform,
  deliver,
  genId,
  doDeliverTask,
  doPerformTask,
) where
import Data.Functor ((<&>))
import Effectful
import Effectful.Concurrent.Async (forConcurrently_, Concurrent)
import Effectful.Dispatch.Dynamic
import Effectful.Fail (Fail, runFail)
import Puppy.Context
import Puppy.Crypto.RNG (RNG, genBytes)
import Puppy.Database (DB)
import Puppy.Logging
import Puppy.Protocol.ActivityStreams
import Puppy.Protocol.HTTP (HTTP, post, get, Response (..))
import Puppy.TaskQueue
import Puppy.Types (Channel (..), ChannelSettings (..))
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64.URL as BS
import qualified Puppy.Database as DB
import qualified Puppy.Protocol.ActivityPub.Fetch as F
-- | An effect for talking to other nodes over ActivityPub.
data ActivityPub :: Effect where
  Resolve :: forall obj m. (F.Dereference obj) => Either JSON.Value Id -> ActivityPub m obj
  Perform :: Activity Object -> Channel -> ActivityPub m ()
  Deliver :: Activity Object -> Channel -> ActivityPub m ()
type instance DispatchOf ActivityPub = 'Dynamic
-- | Resolve an `Id` to an ActivityStreams object.
resolve :: (ActivityPub :> es, F.Dereference obj) => Id -> Eff es obj
resolve = send . Resolve . Right
-- | Assume that the given `Value` is the JSON representation of `obj` and attempt to parse it.
dereference :: (ActivityPub :> es, F.Dereference obj) => JSON.Value -> Eff es obj
dereference = send . Resolve . Left
-- | Schedule a perform task for the given activity, using the given channel for request
-- signatures.
perform :: (ActivityPub :> es) => Activity Object -> Channel -> Eff es ()
perform activity channel = send (Perform activity channel)
-- | Schedule a deliver task for the given activity, using the given channel for request
-- signatures.
deliver :: (ActivityPub :> es) => Activity Object -> Channel -> Eff es ()
deliver activity channel = send (Deliver activity channel)
-- | Generate an ActivityPub ID.
genId :: (ServerInfo :> es, RNG :> es) => Eff es Id
genId = do
  suffix <- BS.encodeBase64 <$> genBytes 32
  localId ("/ap/o/" <> suffix)
-- | Run the ActivityPub effect. Object resolution goes through HTTP, whereas the tasks for performing and
-- delivering activities are sent to their associated worker threads.
runActivityPub
  :: (
    TaskQueue DeliverTask :> es,
    TaskQueue PerformTask :> es,
    Fail :> es,
    HTTP :> es,
    Log :> es
  ) => Eff (ActivityPub : es) a
    -> Eff es a
runActivityPub = interpret $ \_ -> \case
  Resolve (Left json) -> F.runFetch json F.dereferencer
  Resolve (Right (Id url)) -> do
    json <- get url >>= parseJSON
    F.runFetch json F.dereferencer
  Perform activity channel -> enqueue (PerformTask activity channel)
  Deliver activity channel -> enqueue (DeliverTask activity channel)
  where
    parseJSON :: (Fail :> es) => Response -> Eff es JSON.Value
    parseJSON (Response { body }) =
      case JSON.decode (BS.fromStrict body) of
        Just value -> pure value
        Nothing -> fail "Couldn't decode body"
doDeliverTask
  :: (
    Concurrent :> es,
    HTTP :> es,
    Log :> es
  ) => Activity Object
    -> Eff es ()
doDeliverTask activity = scope "deliver" $ do
  let payload = preparePayload activity
  -- TODO: Add retry mechanism
  forConcurrently_ (activity.to <> activity.cc) $ \(Inbox inbox) -> do
    debug ("Delivering to: " <> inbox)
    runFail (post payload inbox) >>= \case
      Left _ -> warn ("Failed to deliver to " <> inbox)
      Right resp
        | resp.statusCode > 299 -> warn "Encountered non-200 status code"
        | otherwise -> debug "Delivery OK"
  where
    -- Prepare a payload by folding the `object` field into just the id of the
    -- object instead of the entire thing, and then converting the entire thing
    -- to a JSON value.
    preparePayload :: Activity Object -> JSON.Value
    preparePayload aty = JSON.toJSON $ aty <&> (.id)
doPerformTask
  :: (
    ActivityPub :> es,
    Log :> es,
    DB :> es,
    Fail :> es,
    RNG :> es,
    ServerInfo :> es
  ) => Activity Object
    -> Eff es ()
doPerformTask a = scope "perform" $ do
  DB.storeActivity a
  case a.subtype of
    -- Handle requests to follow between actors.
    Follow | Just (followee :: Actor) <- fromObject a.object
      -> do
        DB.insertFollowRequest (a.actor, followee.id)
        DB.getChannelByActorId followee.id >>= \case
          -- If the channel has follow autoaccept turned on, proceed to automatically accept
          -- the follow request.
          Just channel | channel.settings.autoAcceptFollows -> acceptFollow channel
          Just _  -> debug "Not automatically accepting follow request due to channel settings"
          Nothing -> debug "Follow request does not target a channel, not doing anything"
    Accept | Just o@Activity { subtype = Follow } <- fromObject a.object,
             Just (followee :: Actor) <- fromObject o.object
      -> do
        debug ("Accepting follow request: " <> o.actor.url <> " to " <> followee.id.url)
        DB.acceptFollowRequest (o.actor, followee.id)
    Undo | Just o@Activity { subtype = Follow } <- fromObject a.object,
           Just (followee :: Actor) <- fromObject o.object
      -> do
        debug "Cancelling follow request"
        DB.cancelFollowRequest (o.actor, followee.id)
    ty -> do
      fail ("Combination of activity type " <> show ty <> " and object type unknown")
  where
    -- | Autoaccept a follow request targeting `channel`.
    acceptFollow channel = do
      debug "Automatically accepting follow request for channel"
      reply <- do
        activityId <- genId
        follower :: Actor <- resolve a.actor
        target <- case follower.inbox of
          Just inbox -> pure inbox
          Nothing -> fail "No inbox available for follow requester"
        pure (Activity {
          id      = activityId,
          actor   = Id channel.linkedActorId,
          object  = toObject a,
          to      = [target],
          cc      = [],
          time    = Nothing,
          subtype = Accept
        })
      deliver reply channel
      perform reply channel

File addition: ActivityPub (d--x------)
[0.10950]

File addition: Fetch.hs (----------)

[0.34330]

{-# LANGUAGE DerivingStrategies #-}
-- | Dereferencing 
module Puppy.Protocol.ActivityPub.Fetch (
  Dereference (..),
  Fetch,
  runFetch,
) where
import Control.Applicative (Alternative (..), optional)
import Control.Monad (when)
import Data.Aeson (Key, FromJSON)
import Data.Aeson.KeyMap ((!?))
import Data.ByteString.Lazy (fromStrict)
import Data.Function ((&))
import Data.Maybe (fromJust)
import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Dynamic (interpret)
import Effectful.Fail (Fail (..))
import Effectful.NonDet (NonDet, runNonDet, OnEmptyPolicy (..))
import Effectful.Reader.Static
import Puppy.Crypto.RSA
import Puppy.Protocol.ActivityStreams
import Puppy.Protocol.HTTP
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.Text.Encoding as T
-- | A restricted monad for writing dereferencing "scripts".
newtype Fetch o
  = Fetch { eff :: Eff '[Reader State, NonDet, HTTP, Fail] o }
  deriving newtype (Functor, Applicative, Alternative, Monad, MonadFail)
data State = State { value :: JSON.Value, depth :: Int }
runFetch
  :: (HTTP :> es, Fail :> es)
  => JSON.Value
  -> Fetch o
  -> Eff es o
runFetch json (Fetch eff) = do
  -- `inject` narrows the list of effects expected by `runNonDet`
  -- to the restricted subset of `eff` (see the `toPoly` example
  -- in the haddocs for `inject`)
  result <- inject eff
    & runBacktrack
    -- Keeping the state is more efficient according to the docs
    & runNonDet OnEmptyKeep
    & runReader (State json 0)
  case result of
    Left _ -> fail "Failed to fetch"
    Right ok -> do
      -- TODO: Add caching here
      pure ok
  where
    -- | Backtrack on failures by triggering NonDet.
    runBacktrack = interpret $ \_ (Fail _) -> empty
class Dereference o where
  dereferencer :: Fetch o
-- | Depth limit to prevent attacks against the dereferencer.
limit :: Int
limit = 10
-- | Fetch a URL from the interwebs.
fetch :: (FromJSON o) => Text -> Fetch o
fetch url = Fetch $ do
  response <- get url
  case JSON.eitherDecode (fromStrict response.body) of
    Left err -> fail ("Error with decoding response: " <> err <> "; data: " <> show response.body)
    Right value -> pure value
deref :: (Dereference o) => Key -> Fetch o
deref key = Fetch $ do
  -- Increment the depth so we don't end up in a dereferencing loop
  local (\st -> st { depth = st.depth + 1 }) $ do
    -- Check depth limiter
    current <- asks depth
    when (current >= limit) $ do
      fail "Depth limit exceeded"
    -- Extract the url to request the data from
    val <- (parse key).eff
    result <- case val of
      JSON.String url -> (fetch url).eff
      JSON.Object _ -> pure val
      _ -> fail ("No url at key " <> show key)
    -- Execute the dereferencer
    runFetch result dereferencer 
parse :: (FromJSON o) => Key -> Fetch o
parse key = Fetch $ do
  val <- asks value
  case extract val >>= decoder of
    Just x  -> pure x
    Nothing -> fail ("Failed to parse field " <> show key)
  where
    decoder = JSON.parseMaybe JSON.parseJSON
    extract = \case { JSON.Object obj -> obj !? key; _ -> Nothing }
focus :: Key -> Fetch o -> Fetch o
focus key action = Fetch $ do
  val <- asks value
  obj <- case val of
    JSON.Object obj -> case obj !? key of
      Just value -> pure value
      Nothing -> fail ("Expected " <> show key <> " to be present")
    -- TODO: catch this case earlier
    _ -> fail "Expected an object"
  local
    (\st -> st { value = obj }) 
    action.eff
instance Dereference o => Dereference (Activity o) where
  dereferencer = Activity
    <$> parse "id"
    <*> parse "actor"
    <*> deref "object"
    <*> (parse "to" <|> pure [])
    <*> (parse "cc" <|> pure [])
    <*> optional (parse "published")
    <*> parse "type"
instance Dereference Actor where
  dereferencer = do
    publicKey <- focus "publicKey" $ do
      PublicKey <$> parse "id" 
                <*> parse "owner"
                <*> (fromJust . decodePublicKey . T.encodeUtf8 <$> parse "publicKeyPem")
    Actor
      <$> parse "id"
      <*> optional (parse "inbox")
      <*> optional (parse "outbox")
      <*> optional (parse "followers")
      <*> optional (parse "following")
      <*> parse "preferredUsername"
      <*> optional (parse "name")
      <*> optional (parse "summary")
      <*> return publicKey
      <*> (parse "manuallyApprovesFollowers" <|> pure True)
      <*> parse "type"
instance Dereference Document where
  dereferencer = Document
    <$> parse "id"
    <*> optional (parse "content")
    <*> optional (parse "summary")
    <*> (parse "type" <|> pure Note)
instance Dereference Object where
  dereferencer = 
    (toObject <$> (dereferencer :: Fetch Actor)) <|>
    (toObject <$> (dereferencer :: Fetch (Activity Object))) <|>
    (toObject <$> (dereferencer :: Fetch Document))

File addition: Logging.hs (----------)

[0.9073]

{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE TemplateHaskell     #-}
module Puppy.Logging (
  LogContext (..),
  genTracer,
  Level (..),
  Tracer,
  -- * Effect
  Log,
  -- * Actions
  -- | Get the current logging context.
  getContext,
  -- | Override the current logging context.
  setContext,
  -- | Push a scope segment to the stack.
  scope,
  debug,
  info,
  warn,
  -- * Handlers
  runLog,
) where
import Control.Monad (when)
import Crypto.Random
import Data.Functor ((<&>))
import Data.Text (Text, justifyRight)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Reader.Dynamic
import Effectful.TH (makeEffect)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BS
import qualified Data.Text.IO as T
data LogContext
  = LogRequest { scopeLabel :: Text, tracer :: Tracer }
  | LogGeneral { scopeLabel :: Text }
newtype Tracer
  = Tracer { getTracerBytes :: BS.ByteString }
genTracer :: (MonadIO m) => m Tracer
genTracer = Tracer <$> liftIO (getRandomBytes 8)
data Level = Debug | Info | Warn deriving (Enum, Eq, Ord)
data Log :: Effect where
  GetContext   :: Log m LogContext
  SetContext   :: LogContext -> m a -> Log m a
  DebugMessage :: Text -> Log m ()
  InfoMessage  :: Text -> Log m ()
  WarnMessage  :: Text -> Log m ()
  Scope        :: Text -> m a -> Log m a
makeEffect ''Log
-- | Insert a message into the log.
debug, info, warn :: (Log :> es) => Text -> Eff es ()
debug = debugMessage
info  = infoMessage
warn  = warnMessage
-- | Run the logging effect.
runLog
  :: (IOE :> es)
  => LogContext
  -> Level
  -> Eff (Log : es) a
  -> Eff es a
runLog logContext lvl = reinterpret (runReader logContext) $ \env x -> do
  label <- asks scopeLabel
  trace <- ask <&> \case
    LogRequest { tracer } -> " [" <> BS.encodeBase64 (getTracerBytes tracer) <> "]"
    _ -> ""
  let writeMessage :: IOE :> es => Text -> Text -> Eff es ()
      writeMessage level msg = liftIO (T.putStrLn (justifyRight 9 ' ' ("[" <> level <> "]") <> trace <> " (" <> label <> "): " <> msg))
  case x of
    GetContext -> ask
    SetContext ctx rest -> localSeqUnlift env $ \unlift -> do
      local (const ctx) (unlift rest)
    -- Modify the context label
    Scope name rest -> localSeqUnlift env $ \unlift -> do
      local (\c -> c { scopeLabel = c.scopeLabel <> "::" <> name }) $ unlift rest
    -- Print messages at different severities
    DebugMessage msg -> when (lvl <= Debug) (writeMessage "debug" msg)
    InfoMessage msg -> when (lvl <= Info) (writeMessage "info" msg)
    WarnMessage msg -> when (lvl <= Warn) (writeMessage "warning" msg)

File addition: Files.hs (----------)

[0.9073]

{-# LANGUAGE TemplateHaskell #-}
-- | Allows access to files relevant to the server only.
module Puppy.Files where
import Effectful
import Effectful.TH (makeEffect)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Aeson as JSON
import Effectful.Dispatch.Dynamic
import System.Directory (doesFileExist)
data Files :: Effect where
  ReadConfigFile  :: Files m (Maybe JSON.Object)
  ReadFavicon     :: Files m LBS.ByteString  
  ReadServerKey   :: Files m (Maybe LBS.ByteString)
  WriteConfigFile :: JSON.Object -> Files m ()
  WriteServerKey  :: LBS.ByteString -> Files m ()
makeEffect ''Files
runFiles
  :: (IOE :> es)
  => FilePath
  -- ^ The path to the state directory
  -> FilePath
  -- ^ The path to the static resources directory
  -> Eff (Files : es) a
  -> Eff es a
runFiles stateMnt resMnt = interpret $ \_ -> liftIO . \case
  ReadConfigFile -> do
    let fp = stateMnt <> "/config.json"
    doesFileExist fp >>= \case
      True -> JSON.decode <$> LBS.readFile fp
      False -> return Nothing   
  ReadFavicon -> LBS.readFile (resMnt <> "/favicon.png")
  ReadServerKey -> do
    let fp = stateMnt <> "/serverKey"
    doesFileExist fp >>= \case
      True -> Just <$> LBS.readFile fp
      False -> return Nothing   
  WriteConfigFile cfg -> LBS.writeFile (stateMnt <> "/config.json") (JSON.encode cfg)
  WriteServerKey key -> LBS.writeFile (stateMnt <> "/serverKey") key

File addition: Database.hs (----------)

[0.9073]

{-# OPTIONS_GHC -Wno-orphans        #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE ApplicativeDo          #-}
{-# LANGUAGE DuplicateRecordFields  #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE TemplateHaskell        #-}
-- | Querying and manipulating the database.
module Puppy.Database (
  connect,
  Connection,
  -- * Effect
  DB,
  runDB,
  -- * Utils
  transaction,
  -- * Queries
  getActorById,
  getChannelByActorId,
  getActivityById,
  getObjectById,
  getUserByName,
  -- * Actions
  insertNewUser,
  insertNewChannel,
  insertNewActor,
  insertNewActivity,
  insertFollowRequest,
  acceptFollowRequest,
  cancelFollowRequest,
  storeActivity,
) where
import Control.Monad ((>=>))
import Database.SQLite.Simple (Connection, query, Only (..), execute, ToRow (..), withTransaction, open)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.FromRow
import Database.SQLite.Simple.ToField (ToField (..))
import Data.Functor ((<&>), ($>))
import Data.Maybe (fromJust)
import Data.Text (Text)
import Data.Time
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Fail (Fail)
import Effectful.TH (makeEffect)
import Prelude hiding (id)
import Puppy.Protocol.ActivityStreams
import Puppy.Types
import qualified Data.Aeson as JSON
import qualified Data.UUID as UUID
import qualified Puppy.Crypto.RSA as RSA
data DB :: Effect where
  GetActorById        :: Id -> DB m (Maybe Actor)
  GetChannelByActorId :: Id -> DB m (Maybe Channel)
  GetUserByName       :: Text -> DB m (Maybe User)
  GetActivityById     :: Id -> DB m (Maybe (Activity Id))
  InsertNewUser       :: User -> DB m ()
  InsertNewChannel    :: Channel -> DB m ()
  InsertNewActor      :: Actor -> DB m ()
  InsertNewActivity   :: Activity Id -> DB m ()
  InsertNewDocument   :: Document -> DB m ()
  Transaction         :: m a -> DB m a
  InsertFollowRequest :: (Id, Id) -> DB m ()
  AcceptFollowRequest :: (Id, Id) -> DB m ()
  CancelFollowRequest :: (Id, Id) -> DB m ()
makeEffect ''DB
getObjectById :: DB :> es => Id -> Eff es (Maybe Object)
getObjectById objId = getActivityById objId >>= \case
  -- TODO: Add branch for Document
  Just activity -> getObjectById activity.object <&> fmap
    (\(obj :: Object) -> toObject (activity $> obj))
  Nothing -> getActorById objId <&> fmap toObject
-- | Store the object, and then store the activity itself.
storeActivity :: (DB :> es) => Activity Object -> Eff es ()
storeActivity a =
  storeObject a.object >> insertNewActivity (a <&> (.id))
  where 
    storeObject obj
      | Just o <- fromObject obj = insertNewActor o
      | Just o <- fromObject obj = insertNewDocument o
      | Just o <- fromObject obj = storeActivity o
      | otherwise = error "impossible!"
connect :: (IOE :> es) => Eff es Connection
connect = liftIO $ open ".state/db.sqlite"
runDB
  :: (IOE :> es, Fail :> es)
  => Connection
  -> Eff (DB : es) a
  -> Eff es a
runDB conn = interpret $ \env a -> do
  localSeqUnliftIO env $ \unlift -> case a of
    GetActorById actorId -> just <$> query conn
      "select id, inbox, outbox, followers, following, accountName, displayName, bio, keyId, publicKeyPem, locked, type from actors where id = ?"
      (Only actorId)
    GetChannelByActorId actorId -> just <$> query conn
      "select id, linkedActorId, privateKeyPem from channels where linkedActorId = ?"
      (Only actorId)
    GetUserByName userName -> just <$> query conn
      "select id, userName from users where userName = ?"
      (Only userName)
    GetActivityById activityId -> just <$> query conn
      "select id, actor, object, audienceTo, audienceCc, time, type from activities where id = ?"
      (Only activityId)
    InsertNewUser (User { userId, userName, mainChannel }) -> execute conn
      "insert into users (id, userName, mainChannel) values (?, ?, ?)"
      (userId, userName, mainChannel)
    InsertNewChannel (Channel { channelId, linkedActorId, privateKeyPem }) -> execute conn
      "insert into channels (id, linkedActorId, privateKeyPem) values (?, ?, ?)"
      (channelId, linkedActorId, RSA.encodePrivateKey privateKeyPem)
    InsertNewActor actor -> execute conn
      "insert into actors (id, inbox, outbox, followers, following, accountName, displayName, bio, keyId, publicKeyPem, locked, type) values (?,?,?,?,?,?,?,?,?,?,?,?) on conflict do nothing"
      actor
    InsertNewDocument _ -> pure () -- TODO
    InsertNewActivity activity -> execute conn
      "insert into activities (id, actor, object, audienceTo, audienceCc, time, type) values (?, ?, ?, ?, ?, ?, ?) on conflict do nothing"
      activity
    Transaction actions -> withTransaction conn (unlift actions)
    InsertFollowRequest (follower, followee) -> execute conn
      "insert into follows (follower, followee) values (?, ?)"
      (follower, followee)
    AcceptFollowRequest (follower, followee) -> do -- NOTE: Applicative do
      record <- just <$> query conn 
        "select acceptTime, rejectTime, follower, followee from follows where follower = ? and followee = ?"
        (follower, followee)
      now <- getCurrentTime
      case record of
        Just (rec :: FollowRecord) -> execute conn
          "update follows set acceptTime = ? where follower = ? and followee = ?"
          (now, rec.follower, rec.followee)
        Nothing -> execute conn
          "insert into follows (follower, followee, acceptTime) values (?, ?, ?)"
          (follower, followee, now)
    CancelFollowRequest inputs -> execute conn
      "delete from follows where follower = ? and followee = ?"
      inputs
  where
    just [a] = Just a
    just _   = Nothing
instance FromRow Actor where
  fromRow = do -- NOTE: Applicative do
    -- NOTE: Order of `field`s matters here
    !id           <- field
    !inbox        <- field
    !outbox       <- field
    !followers    <- field
    !following    <- field
    !accountName  <- field
    !displayName  <- field
    !summary      <- field
    !publicKeyId  <- field
    !publicKeyPem <- field <&> fromJust . RSA.decodePublicKey
    !locked       <- field
    !subtype      <- field
    pure (Actor {
      publicKey = PublicKey {
        id = publicKeyId,
        owner = id,
        publicKeyPem
      },
      ..
    })
instance ToRow Actor where
  toRow a = [
      toField a.id,
      toField a.inbox,
      toField a.outbox,
      toField a.followers,
      toField a.following,
      toField a.accountName,
      toField a.displayName,
      toField a.summary,
      toField a.publicKey.id,
      toField (RSA.encodePublicKey a.publicKey.publicKeyPem),
      toField a.locked,
      toField a.subtype
    ]
instance FromRow Channel where
  fromRow = do -- NOTE: Applicative do
    -- NOTE: Order of `field`s matters here
    !channelId     <- field
    !linkedActorId <- field
    !privateKeyPem <- field <&> fromJust . RSA.decodePrivateKey
    let settings = ChannelSettings { autoAcceptFollows = True }
    pure (Channel { .. })
instance FromRow User where
  -- NOTE: Order of `field`s matters here
  fromRow = User <$> field
                 <*> field
                 <*> field
instance FromRow (Activity Id) where
  fromRow = do -- NOTE: Applicative do
    -- NOTE: Order of `field`s matters here
    !id      <- field
    !actor   <- field
    !object  <- field
    !to      <- field <&> fromJust . JSON.decode
    !cc      <- field <&> fromJust . JSON.decode
    !time    <- field
    !subtype <- field
    pure (Activity { .. })
instance ToRow (Activity Id) where
  toRow a = [
      toField a.id,
      toField a.actor,
      toField a.object,
      toField (JSON.encode a.to),
      toField (JSON.encode a.cc),
      toField a.time,
      toField a.subtype
    ]
data FollowRecord
  = FollowRecord {
    acceptTime :: Maybe UTCTime,
    rejectTime :: Maybe UTCTime,
    follower   :: Id,
    followee   :: Id
  }
instance FromRow FollowRecord where
  fromRow = do -- NOTE: Applicative do
    -- NOTE: Order of `field`s matters here
    !acceptTime <- field
    !rejectTime <- field
    !follower   <- field
    !followee   <- field
    pure (FollowRecord { .. })
instance ToRow FollowRecord where
  toRow a = [
      toField a.acceptTime,
      toField a.rejectTime,
      toField a.follower,
      toField a.followee
    ]
instance FromField Id where
  fromField = fmap Id . fromField
instance ToField Id where
  toField = toField . (.url)
instance FromField Inbox where
  fromField = fmap Inbox . fromField
instance ToField Inbox where
  toField = toField . (.url)
instance FromField UUID.UUID where
  fromField = fmap (fromJust . UUID.fromByteString)
            . fromField
instance ToField UUID.UUID where
  toField = toField . UUID.toByteString 
instance forall o. FromField (Subtype (Activity o)) where
  fromField = fromField >=> \case
    "Follow"  -> pure Follow
    "Accept"  -> pure Accept
    "Reject"  -> pure Reject
    "Create"  -> pure Create
    "Delete"  -> pure Delete
    "Announce"-> pure Announce
    "Like"    -> pure Like
    "Undo"    -> pure Undo
    (str :: Text) -> fail ("Bad subtype of Activity: " <> show str)
instance forall o. ToField (Subtype (Activity o)) where
  toField Follow   = toField ("Follow"   :: Text)
  toField Accept   = toField ("Accept"   :: Text)
  toField Reject   = toField ("Reject"   :: Text)
  toField Create   = toField ("Create"   :: Text)
  toField Delete   = toField ("Delete"   :: Text)
  toField Announce = toField ("Announce" :: Text)
  toField Like     = toField ("Like"     :: Text)
  toField Undo     = toField ("Undo"     :: Text)
instance FromField (Subtype Actor) where
  fromField = fromField >=> \case
    "Person"       -> pure Person
    "Service"      -> pure Service
    "Application"  -> pure Application
    "Organization" -> pure Organization
    "Group"        -> pure Group
    (str :: Text)  -> fail ("Bad subtype of Actor: " <> show str)
instance ToField (Subtype Actor) where
  toField Person       = toField ("Person"       :: Text)
  toField Service      = toField ("Service"      :: Text)
  toField Application  = toField ("Application"  :: Text)
  toField Organization = toField ("Organization" :: Text)
  toField Group        = toField ("Group"        :: Text)

File addition: Crypto.hs (----------)

[0.9073]

-- | Cryptography utilities.
module Puppy.Crypto (sha256, base64) where
import Crypto.Hash (Digest, SHA256, hash)
import Data.ByteString.Base64 (encodeBase64')
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
class Base64 x where
  -- | Base64-encode something
  base64 :: x -> x
instance Base64 BS.ByteString where
  base64 = encodeBase64'
-- | Hash a ByteString with SHA-256
sha256 :: BS.ByteString -> BS.ByteString
sha256 = BA.pack
       . BA.unpack
       . (hash :: BS.ByteString -> Digest SHA256)

File addition: Crypto (d--x------)
[0.9073]

File addition: RSA.hs (----------)

[0.54132]

module Puppy.Crypto.RSA where
import Data.List (singleton)
import Effectful
import Effectful.Fail
import qualified Crypto.PubKey.RSA  as RSA
import qualified Crypto.Store.PKCS8 as PKCS8
import qualified Crypto.Store.X509  as X509
import qualified Data.ByteString    as BS
import qualified Data.X509          as X509
encodePrivateKey :: RSA.PrivateKey -> BS.ByteString
encodePrivateKey
  = PKCS8.writeKeyFileToMemory PKCS8.PKCS8Format
  . singleton
  . X509.PrivKeyRSA
decodePrivateKey :: BS.ByteString -> Maybe RSA.PrivateKey
decodePrivateKey
  = extract
  . PKCS8.readKeyFileFromMemory
  where
    extract ((PKCS8.Unprotected (X509.PrivKeyRSA x)):_) = Just x
    extract (_ : rest) = extract rest
    extract _ = Nothing
encodePublicKey :: RSA.PublicKey -> BS.ByteString
encodePublicKey
  = X509.writePubKeyFileToMemory
  . singleton
  . X509.PubKeyRSA
decodePublicKey :: BS.ByteString -> Maybe RSA.PublicKey
decodePublicKey
  = extract
  . X509.readPubKeyFileFromMemory
  where
    extract ((X509.PubKeyRSA x):_) = Just x
    extract (_ : rest) = extract rest
    extract _ = Nothing
readKeyFile :: (IOE :> es, Fail :> es) => FilePath -> Eff es RSA.PrivateKey
readKeyFile path = liftIO (decodePrivateKey <$> BS.readFile path) >>= \case
  Just x  -> return x
  Nothing -> fail "Bad key file"

File addition: RNG.hs (----------)

[0.54132]

{-# LANGUAGE TemplateHaskell #-}
-- | An effect for generating random values.
module Puppy.Crypto.RNG (
  -- * Effect
  RNG,
  -- * Handler
  runRNG,
  -- * Actions
  genUUID,
  genRSA,
  genBytes,
) where
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.TH (makeEffect)
import Crypto.Random (MonadRandom (..))
import Data.UUID (UUID)
import qualified Crypto.PubKey.RSA as RSA
import qualified Data.ByteString   as BS
import qualified Data.UUID.V4      as UUID
-- | An effect for generating random values.
data RNG :: Effect where
  GenRSA   :: RNG m (RSA.PublicKey, RSA.PrivateKey)
  GenUUID  :: RNG m UUID
  GenBytes :: Int -> RNG m BS.ByteString
type instance DispatchOf RNG = 'Dynamic
-- | A handler for the `RNG` effect.
runRNG
  :: (IOE :> es)
  => Eff (RNG : es) a
  -> Eff es a
runRNG = interpret $ \_ -> \case
  GenRSA  -> liftIO (RSA.generate 1024 65537)
  GenUUID -> liftIO UUID.nextRandom
  GenBytes len -> liftIO (getRandomBytes len)
makeEffect ''RNG

File addition: Context.hs (----------)

[0.9073]

{-# LANGUAGE TemplateHaskell          #-}
{-# LANGUAGE DisambiguateRecordFields #-}
module Puppy.Context (
  -- * Effect
  ServerInfo,
  -- * Actions
  localActorId,
  localUrl,
  localId,
  serverActor,
  nodeName,
  -- * Handlers
  runServerInfo
) where
import Crypto.PubKey.RSA (PrivateKey (..))
import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.TH (makeEffect)
import Puppy.Config
import Puppy.Protocol.ActivityStreams (Id (..), Actor (..), PublicKey (..), Subtype (..), Inbox (..))
-- | Query information about the server.
data ServerInfo :: Effect where
  NodeName :: ServerInfo m Text
  ServerActor :: ServerInfo m Actor
makeEffect ''ServerInfo
-- | Create an `Id` for a local actor given only a name.
localActorId
  :: (ServerInfo :> es)
  => Text
  -> Eff es Id
localActorId actorName = localId ("/ap/a/" <> actorName)
localUrl :: (ServerInfo :> es) => Text -> Eff es Text
localUrl suffix = do
  us <- nodeName
  return ("https://" <> us <> suffix)
localId :: (ServerInfo :> es) => Text -> Eff es Id
localId = fmap Id . localUrl
runServerInfo :: (Config :> es) => Eff (ServerInfo : es) a -> Eff es a
runServerInfo = interpret $ \_ -> \case
  NodeName -> getsConfig name
  ServerActor -> do
    config <- getConfig
    let actorId = Id ("https://" <> config.name <> "/ap/a/server")
    return (Actor {
      id = actorId,
      accountName = "server",
      publicKey = PublicKey {
        id = Id (actorId.url <> "#key"),
        publicKeyPem = config.serverKey.private_pub,
        owner = actorId
      },
      inbox = Just (Inbox (actorId.url <> "/inbox")),
      outbox = Nothing,
      followers = Nothing,
      following = Nothing,
      displayName = Nothing,
      summary = Nothing,
      locked = True,
      subtype = Service
  })

File addition: Config.hs (----------)

[0.9073]

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
module Puppy.Config where
import Data.Functor ((<&>), ($>))
import Data.String (IsString)
import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Dynamic (interpret)
import Effectful.Fail (Fail)
import Effectful.NonDet
import Effectful.TH
import Puppy.Crypto.RNG
import Puppy.Crypto.RSA
import Puppy.Files
import Puppy.Logging
import qualified Crypto.PubKey.RSA as RSA
import qualified Data.Aeson.KeyMap as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.ByteString as BS
import System.Environment (lookupEnv)
version :: IsString s => s
version = "0.1.0"
getLogLevel :: MonadIO m => m Level
getLogLevel = liftIO $ do
  lookupEnv "KAOS_LOG_LEVEL" <&> \case
    Just "debug" -> Debug
    Just "info"  -> Info
    Just "warn"  -> Warn
    _ -> Info
data ServerConfig
  = ServerConfig {
    port      :: Int,
    name      :: Text,
    serverKey :: RSA.PrivateKey,
    logLevel  :: Level
  }
data Config :: Effect where
  GetConfig  :: Config m ServerConfig
  GetsConfig :: (ServerConfig -> a) -> Config m a
makeEffect ''Config
runConfig
  :: ServerConfig
  -> Eff (Config : es) a
  -> Eff es a
runConfig config = interpret $ \_ -> \case
  GetConfig    -> pure config
  GetsConfig f -> pure (f config)
loadConfig 
  :: (Files :> es, RNG :> es, Fail :> es, IOE :> es)
  => Eff es ServerConfig
loadConfig = do
    cfg <- require ".state/config.json" =<< readConfigFile
    logLevel  <- getLogLevel
    -- Attempt to load the key file, and generate a key if one doesn't exist yet.
    serverKey <- loadServerKey
    res <- runNonDet OnEmptyKeep $ do
      port <- require "'port'" 
              (parse cfg "port" <|> pure 1312)
      name <- require "'name'"
              (parse cfg "name")
      pure (ServerConfig { .. })
    either (const (fail "boo")) return res
  where
    parse :: (JSON.FromJSON v) => JSON.Object -> JSON.Key -> Maybe v
    parse obj key = JSON.lookup key obj >>= mayb . JSON.fromJSON
    mayb = \case { JSON.Error _ -> Nothing; JSON.Success a -> Just a }
    require :: (Fail :> xs) => String -> Maybe e -> Eff xs e
    require msg = \case
      Just v -> pure v
      Nothing -> fail ("Requires " <> msg <> " but it is missing")
    loadServerKey = readServerKey >>= \case
      Just key -> case decodePrivateKey (BS.toStrict key) of
        Just k -> return k
        Nothing -> fail "Bad private key!"
      Nothing -> do
        (_, key) <- genRSA
        writeServerKey (BS.fromStrict $ encodePrivateKey key) $> key

File addition: Kaos (d--x------)
[0.9056]
File addition: Protocol (d--x------)
[0.60936]
File addition: ActivityPub (d--x------)
[0.60954]
File addition: Resolve.hs (----------)
[0.60976]
File addition: Deliver.hs (----------)
[0.60976]
File addition: app (d--x------)
[0.9039]
File addition: cli (d--x------)
[0.61077]
File addition: Main.hs (----------)
[0.61094]
File addition: api (d--x------)
[0.61077]

File addition: Router.hs (----------)

[0.61146]

module Router (dispatch) where
import Data.Functor ((<&>))
import Data.Result
import Effectful
import Effectful.Fail (Fail)
import Network.Wai (Request (..))
import Puppy.Context
import Puppy.Database (DB)
import Puppy.Files (Files, readFavicon)
import Puppy.Logging
import Puppy.Protocol.ActivityPub (ActivityPub)
import Puppy.Protocol.ActivityStreams (Id(..))
import qualified API.ActivityPub
import qualified API.WebFinger
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text            as T
import qualified Data.Text.Encoding   as T
dispatch 
  :: (
    DB :> es,
    Fail :> es,
    Files :> es,
    Log :> es,
    ActivityPub :> es,
    ServerInfo :> es
  ) => Request
    -> LBS.ByteString
    -> Eff es Result
dispatch req body = do
  target <- localUrl (T.decodeUtf8 req.rawPathInfo)
  let method = req.requestMethod
      path = req.pathInfo
  info (T.unwords ["Handling", T.decodeUtf8 method, "'/" <> T.intercalate "/" path <> "'"])
  case (method, path) of
    ("GET", [".well-known", "webfinger"]) ->
        -- Forward the request to the WebFinger handler
        API.WebFinger.handleQuery req
    ("GET", ["ap", "a", actorName])
        | actorName == "server" -> API.ActivityPub.serveServerActor
        | otherwise -> API.ActivityPub.serveObject (Id target)
    ("GET", ["ap", "o", _]) ->
        API.ActivityPub.serveObject (Id target)
    ("POST", ["ap", "a", actorName, "inbox"]) ->
        API.ActivityPub.handleInbox actorName body
    ("GET", []) -> 
        return (Bytes { contentType = "text/plain", body = "Hello :)" })
    ("GET", ["favicon.ico"]) ->
        readFavicon <&> Bytes "image/png"
    _ -> do
        info "Rejected: unknown path"
        return (Error { statusCode = 404, errorMessage = "Unknown path" })

File addition: Main.hs (----------)

[0.61146]

{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NoFieldSelectors      #-}
module Main where
import Control.Exception.Base (handle, SomeException (..))
import Control.Monad ((>=>), forever)
import Data.Functor (void, ($>))
import Data.Result
import Data.String (IsString (..))
import Effectful
import Effectful.Concurrent.Async (runConcurrent, async, waitAnyCancel)
import Effectful.Concurrent.Chan (Chan, newChan)
import Effectful.Fail (runFailIO, runFail, Fail)
import Effectful.Reader.Static (runReader, Reader)
import Network.HTTP.Conduit (tlsManagerSettings, newManager, Manager)
import Network.Wai.Handler.Warp (run)
import Puppy.Config
import Puppy.Context
import Puppy.Crypto.RNG (runRNG)
import Puppy.Database (runDB)
import Puppy.Files (runFiles, Files)
import Puppy.Logging
import Puppy.Protocol.ActivityPub (runActivityPub)
import Puppy.Protocol.ActivityStreams (Id (..))
import Puppy.Protocol.HTTP (runHTTP)
import Puppy.Protocol.HTTP.Signature (Server (..))
import Puppy.TaskQueue
import qualified Data.Text                  as T
import qualified Network.Wai                as WAI
import qualified Puppy.Database             as DB
import qualified Puppy.Protocol.ActivityPub as AP
import qualified Router
import System.Directory (createDirectoryIfMissing)
main :: IO ()
main = runEff . runRNG . runFiles ".state" "res" $ do
  -- Load the initial configuration
  config <- runFailIO $ do
    liftIO $ createDirectoryIfMissing False ".state"
    loadConfig
  -- Initialize the global HTTP manager
  manager <- liftIO (newManager tlsManagerSettings)
  -- Handle some root effects that require shared context that would
  -- be really annoying to thread down to where it needs to go.
  let handler = runConfig config
              . runServerInfo
              -- Share a single HTTP client between all threads using the HTTP effect.
              -- We don't evaluate the HTTP effect in the global handler, because we
              -- don't want failures to propagate to the main thread. This handler must
              -- not fail unless there is something catastrophically wrong.
              . runReader manager
              -- Initialize the logging root here
              . runLog (LogGeneral { scopeLabel = "main" }) config.logLevel
              -- Need concurrency past this point
              . runConcurrent
              -- Set up the task queue for delivering activities
              . (\x -> (newChan :: Eff _ (Chan DeliverTask)) >>= \q -> runTaskQueue q x)
              -- Set up the task queue for performing activities
              . (\x -> (newChan :: Eff _ (Chan PerformTask)) >>= \q -> runTaskQueue q x)
  -- Actually run the application
  handler $ do
    info "Configuration loaded"
    info "Starting core tasks"
    -- Launch the tasks
    respondTask <- async respond
    performTask <- async perform
    deliverTask <- async deliver
    -- Block until any task returns (which should be never)
    void $ waitAnyCancel [
        respondTask,
        performTask,
        deliverTask
      ]
    info "Server terminated. See ya!"
  where
    -- Take tasks from the queue and handle basic failures by logging their message and then
    -- proceeding to the next task.
    -- NOTE: Does not stop RTS exceptions from taking down the loop
    -- TODO: Add some kind of retry mechanism?
    -- TODO: Add exception handling
    loop :: (TaskQueue task :> es, Log :> es) => (task -> Eff (Fail : es) ()) -> Eff es ()
    loop f = void $ forever $ logFail (dequeue >>= f)
      where
        logFail :: Log :> es => Eff (Fail : es) () -> Eff es ()
        logFail = runFail >=> \case
          Left msg -> warn ("Failed: " <> T.pack msg)
          Right _  -> debug "Finished"
    named = setContext . LogGeneral
    -- | The delivery worker task is responsible for delivering activities
    -- to remote instances.
    deliver = named "task/deliver" $ do
      info "Hello!"
      loop $ \(DeliverTask activity channel) -> do
        let handler = scope activity.id.url
                    -- Set the request signer for HTTP requests to be the channel
                    -- through which the activity is sent.
                    -- HTTP handler needs to be set within the loop, because
                    -- it is fallible, so we need the `Fail` handler that is
                    -- built into `loop`.
                    . runHTTP channel
        handler $ do
          AP.doDeliverTask activity
      info "Stopped"
    -- | The worker task responsible for executing the side effects of
    -- an activity.
    perform = named "task/perform" $ do
      info "Hello!"
      conn <- DB.connect
      loop $ \(PerformTask activity channel) -> do
        let handler = scope activity.id.url
                    -- HTTP handler needs to be set within the loop, because
                    -- it is fallible, so we need the `Fail` handler that is
                    -- built into `loop`.
                    . runHTTP channel
                    . runActivityPub
                    . runDB conn
        handler $ do
          AP.doPerformTask activity
      info "Stopped"
    -- | The server task responsible for accepting requests and responding to
    -- them, as well as delegating to the other two tasks.
    respond = named "task/respond" $ do
      info "Hello!"
      cfg <- getConfig
      conn <- DB.connect
      info (T.unwords ["Starting node", cfg.name, "on port", T.pack (show cfg.port)])
      withConcEffToIO Ephemeral Unlimited $ \unlift -> do
        run cfg.port (app unlift conn)
      info "Stopped"
app
  :: (
    Config :> es,
    Files :> es,
    IOE :> es,
    Log :> es,
    Reader Manager :> es,
    ServerInfo :> es,
    TaskQueue DeliverTask :> es,
    TaskQueue PerformTask :> es
  ) => (forall r. Eff es r -> IO r)
    -> DB.Connection
    -> WAI.Application
app unlift conn request respond = do
  result <- unlift $ do
    config <- getConfig
    tracer <- genTracer
    let context = LogRequest { scopeLabel = "handle", tracer }
        handler = setContext context
                -- Translates `fail` calls into `Result`s describing the error.
                . handleFail
                -- Initialize dependencies for AP ID resolution
                -- TODO: maybe use a connection pool here. can be an effect
                . runDB conn
                -- Set up the HTTP effect handler so failures are caught by `handleFail`
                . runHTTP (Server config)
                . runActivityPub
    -- Doing some unlifting magic here to make the exception handling happen with the
    -- logging context that includes the tracer (as opposed to just using `unlift`,
    -- which would make it so that we lose the context of which request triggered
    -- the exception).
    handler $ withEffToIO $ \effToIO -> do
      effToIO $ handleExceptions effToIO $ do
        body <- liftIO (WAI.strictRequestBody request)
        -- TODO: verify request signature here
        Router.dispatch request body
  respond (toResponse result)
  where
    handleFail :: (Log :> es) => Eff (Fail : es) Result -> Eff es Result
    handleFail = runFail >=> \case
      Left msg
        -> warn ("Uncaught failure: " <> T.pack msg)
        $> Error 500 (fromString msg)
      Right res
        -> debug ("Finished, status: " <> status res)
        $> res
    handleExceptions :: (forall r. Eff _ r -> IO r) -> Eff _ Result -> Eff _ Result
    handleExceptions localUnlift
      = liftIO
      . handle (\ex -> localUnlift (warn ("Exception: " <> T.pack (show ex)) $> genResponse ex))
      . localUnlift
    genResponse :: SomeException -> Result
    genResponse _ = Error 500 "Internal error"
    status = T.pack . show . getStatusCode

File addition: Kaos (d--x------)
[0.61146]
File addition: Task (d--x------)
[0.70774]
File addition: Data (d--x------)
[0.61146]

File addition: Result.hs (----------)

[0.70810]

module Data.Result where
import Data.Aeson (ToJSON, encode, (.=), object)
import Network.Wai (Response, responseLBS)
import qualified Data.ByteString      as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text.Encoding   as T
data Result
  = forall j. ToJSON j => Value j
  | Bytes { contentType :: BS.ByteString, body :: LBS.ByteString }
  | Error { statusCode :: Int, errorMessage :: LBS.ByteString }
  | Empty
toResponse :: Result -> Response
toResponse = \case
  Value json -> responseLBS
    (toEnum 200)
    [("content-type", "application/activity+json")]
    (encode json)
  Bytes contentType body -> responseLBS
    (toEnum 200)
    [("content-type", contentType)]
    body
  Error code body -> responseLBS
    (toEnum code)
    [("content-type", "application/json")]
    (encode $ object [ "error" .= T.decodeUtf8 (BS.toStrict body) ])
  Empty -> responseLBS (toEnum 202) [] ""
getStatusCode :: Result -> Int
getStatusCode = \case
  Bytes _ _    -> 200
  Empty        -> 202
  Error code _ -> code
  Value _      -> 200

File addition: API (d--x------)
[0.61146]

File addition: WebFinger.hs (----------)

[0.71921]

module API.WebFinger (handleQuery) where
import Control.Monad (join)
import Data.Functor ((<&>))
import Data.Result
import Effectful
import Network.Wai (Request (..))
import Puppy.Logging (Log)
import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as T
import qualified Puppy.Protocol.WebFinger as WebFinger
handleQuery
  :: (Log :> es)
  => Request 
  -> Eff es Result
handleQuery req = do
  let resource = 
        join (lookup "resource" (queryString req))
          >>= BS.stripPrefix "acct:"
          >>= WebFinger.parseHandle . T.decodeUtf8
  case resource of
    Just res -> WebFinger.lookupLocal res <&> maybe
      (Error 404 "No such resource")
      Value
    Nothing -> return (Error 400 "Bad resource")

File addition: User.hs (----------)

[0.71921]

{-# LANGUAGE DisambiguateRecordFields #-}
module API.User where
import Data.Text (Text)
import Data.UUID (UUID)
import Effectful
import Puppy.Context
import Puppy.Crypto.RNG (genRSA, genUUID, RNG)
import Puppy.Database
import Puppy.Protocol.ActivityStreams
import Puppy.Types
import qualified Crypto.PubKey.RSA as RSA
createUser
  :: (ServerInfo :> es, DB :> es, RNG :> es)
  => Text
  -> Eff es ()
createUser userName = transaction $ do
  -- Generate the user's ID
  userId <- genUUID
  -- Create default channel
  mainChannel <- createChannel userName
  insertNewUser (User {
    userId,
    userName,
    mainChannel
  })
  
createChannel
  :: (ServerInfo :> es, DB :> es, RNG :> es)
  => Text
  -> Eff es UUID
createChannel accountName = do
  (publicKey, privateKey) <- genRSA
  actorId <- createActor accountName publicKey
  channelId <- genUUID
  insertNewChannel (Channel {
    linkedActorId = actorId,
    privateKeyPem = privateKey,
    channelId,
    settings = (ChannelSettings { autoAcceptFollows = True })
  })
  return channelId
createActor
  :: (ServerInfo :> es, DB :> es)
  => Text
  -> RSA.PublicKey
  -> Eff es Text
createActor accountName publicKeyPem = do
  Id actorId <- localActorId accountName
  insertNewActor (Actor {
    id          = Id actorId,
    inbox       = Just $ Inbox (actorId <> "/inbox"),
    outbox      = Just $ Id (actorId <> "/outbox"),
    followers   = Just $ Id (actorId <> "/followers"),
    following   = Just $ Id (actorId <> "/following"),
    accountName,
    displayName = Nothing,
    summary     = Nothing,
    publicKey   = PublicKey {
      id = Id (actorId <> "#key"),
      owner = Id actorId,
      publicKeyPem
    },
    locked      = True,
    subtype     = Person
  })
  return actorId

File addition: ActivityPub.hs (----------)

[0.71921]

module API.ActivityPub where
import Data.Functor ((<&>))
import Data.Result
import Data.Text (Text)
import Effectful
import Effectful.Fail
import Puppy.Context
import Puppy.Database (DB)
import Puppy.Logging
import Puppy.Protocol.ActivityStreams (Id (..))
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text.Encoding as T
import qualified Puppy.Database as DB
import qualified Puppy.Protocol.ActivityPub as AP
import qualified Puppy.Protocol.ActivityStreams as AS
serveObject :: (DB :> es) => Id -> Eff es Result
serveObject objectId = DB.getObjectById objectId
  <&> maybe (Error 404 "No such object") fixup
  where
    fixup = AS.object (Value . fmap (.id)) Value Value
handleInbox
  :: (
    AP.ActivityPub :> es,
    DB :> es,
    Fail :> es,
    Log :> es,
    ServerInfo :> es
  ) => Text
    -> LBS.ByteString
    -> Eff es Result
handleInbox actorName body = scope "handleInbox" $ do
  -- TODO: verify that the activity actually involves the actor
  Id actorId <- localActorId actorName
  debug ("Processing: " <> T.decodeUtf8 (LBS.toStrict body))
  debug ("Targeted: " <> actorId)
  case JSON.decode body of
    Just json -> do
      activity <- AP.dereference json
      DB.getChannelByActorId (Id actorId) >>= \case
        Just channel -> do
          AP.perform activity channel
          debug "Submitted activity for execution"
          return Empty
        Nothing -> return (Error 404 "Targeted actor does not exist")
    Nothing -> return (Error 400 "Could not decode payload")
serveServerActor
  :: (ServerInfo :> es)
  => Eff es Result
serveServerActor = Value <$> serverActor

File addition: README.md (----------)

[0.9039]

# `src/`
This directory contains the Haskell source code for the ActivityPub server and the accompanying
CLI controller under `app/`, along with the shared library on which they both depend under
`lib/`.

File addition: sql (d--x------)
[2.1]

File addition: 0001.up.sql (----------)

[0.76448]

CREATE TABLE activities (
    id          TEXT  PRIMARY KEY,
    actor       TEXT  NOT NULL,
    object      TEXT  NOT NULL,
    audienceTo  BLOB  NOT NULL,
    audienceCc  BLOB  NOT NULL,
    type        TEXT  NOT NULL,
    time        INTEGER,
    FOREIGN KEY (actor) REFERENCES actors (id)
);
CREATE TABLE follows (
    follower    TEXT  NOT NULL,
    followee    TEXT  NOT NULL,
    acceptTime  INTEGER,
    rejectTime  INTEGER,
    PRIMARY KEY (follower, followee),
    FOREIGN KEY (follower) REFERENCES actors (id),
    FOREIGN KEY (followee) REFERENCES actors (id)
);

File addition: 0001.down.sql (----------)
[0.76448]
```
DROP TABLE activities;
DROP TABLE follows;
```

File addition: 0000.up.sql (----------)

[0.76448]

CREATE TABLE users (
    id          BLOB PRIMARY KEY,
    userName    TEXT NOT NULL,
    mainChannel BLOB NOT NULL,
    FOREIGN KEY (mainChannel) REFERENCES channels (id)
);
CREATE TABLE actors (
    id           TEXT PRIMARY KEY,
    inbox        TEXT,
    outbox       TEXT,
    followers    TEXT,
    following    TEXT,
    accountName  TEXT NOT NULL,
    displayName  TEXT,
    bio          TEXT,
    keyId        TEXT NOT NULL,
    publicKeyPem BLOB NOT NULL,
    locked       BOOL NOT NULL,
    type         TEXT NOT NULL
);
CREATE TABLE channels (
    id            BLOB PRIMARY KEY,
    linkedActorId TEXT NOT NULL,
    privateKeyPem BLOB NOT NULL,
    FOREIGN KEY (linkedActorId) REFERENCES actors (id)
);
CREATE TABLE channel_owners (
    channelId BLOB NOT NULL,
    userId BLOB NOT NULL,
    FOREIGN KEY (channelId) REFERENCES channels (id),
    FOREIGN KEY (userId) REFERENCES users (id)
);

File addition: 0000.down.sql (----------)

[0.76448]

DROP TABLE users;
DROP TABLE actors;
DROP TABLE channels;
DROP TABLE channel_owners;

File addition: res (d--x------)
[2.1]
File addition: favicon.png (----------)
[0.78237]

File addition: package.nix (----------)

[2.1]

{ mkDerivation,
  lib,
  # Haskell dependencies
  aeson,
  base64,
  bytestring,
  cryptonite,
  cryptostore,
  effectful,
  effectful-th,
  hspec,
  http-conduit,
  QuickCheck,
  sqlite-simple,
  text,
  uuid,
  wai,
  warp
}:
mkDerivation {
  
  pname = "activitypuppy";
  version = "0.1.0";
  src = ./.;
  isExecutable = true;
  executableHaskellDepends = [
    aeson
    base64
    bytestring
    cryptonite
    cryptostore
    effectful
    effectful-th
    hspec
    http-conduit
    QuickCheck
    sqlite-simple
    text
    uuid
    wai
    warp
  ];
  license = lib.licenses.mit;
}

File addition: flake.nix (----------)

[2.1]

{
  description = "Flake for ActivityPuppy";
  inputs = {
    nixpkgs.url = "github:NixOS/nixpkgs/nixos-23.05";
    flake-utils.url = "github:numtide/flake-utils";
  };
  outputs = { nixpkgs, flake-utils, ... }: 
    flake-utils.lib.eachDefaultSystem  (system: let 
        pkgs = import nixpkgs { inherit system; };
        hs-env = pkgs.haskell.packages.ghc944.extend (final: prev: {});
        hs-ghc = hs-env.ghcWithPackages
          (hspkgs: with hspkgs; [
            aeson
            base64
            bytestring
            cryptonite
            cryptostore
            effectful
            effectful-th
            hspec
            http-conduit
            QuickCheck
            sqlite-simple
            text
            uuid
            wai
            warp
          ]);
      in rec {
        packages.default = hs-env.callPackage ./package.nix {};
        apps.default = {
          type = "app";
          program = "${packages.default}/bin/kaos-api";
        };
        devShell = pkgs.mkShell {
          buildInputs = [
            hs-ghc
            hs-env.cabal-install
            pkgs.haskell.packages.ghc944.haskell-language-server
            pkgs.sqlite
          ];
        };
      });
}

File addition: flake.lock (----------)

[2.1]

{
  "nodes": {
    "flake-utils": {
      "inputs": {
        "systems": "systems"
      },
      "locked": {
        "lastModified": 1687709756,
        "narHash": "sha256-Y5wKlQSkgEK2weWdOu4J3riRd+kV/VCgHsqLNTTWQ/0=",
        "owner": "numtide",
        "repo": "flake-utils",
        "rev": "dbabf0ca0c0c4bce6ea5eaf65af5cb694d2082c7",
        "type": "github"
      },
      "original": {
        "owner": "numtide",
        "repo": "flake-utils",
        "type": "github"
      }
    },
    "nixpkgs": {
      "locked": {
        "lastModified": 1688109178,
        "narHash": "sha256-BSdeYp331G4b1yc7GIRgAnfUyaktW2nl7k0C577Tttk=",
        "owner": "NixOS",
        "repo": "nixpkgs",
        "rev": "b72aa95f7f096382bff3aea5f8fde645bca07422",
        "type": "github"
      },
      "original": {
        "owner": "NixOS",
        "ref": "nixos-23.05",
        "repo": "nixpkgs",
        "type": "github"
      }
    },
    "root": {
      "inputs": {
        "flake-utils": "flake-utils",
        "nixpkgs": "nixpkgs"
      }
    },
    "systems": {
      "locked": {
        "lastModified": 1681028828,
        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
        "owner": "nix-systems",
        "repo": "default",
        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
        "type": "github"
      },
      "original": {
        "owner": "nix-systems",
        "repo": "default",
        "type": "github"
      }
    }
  },
  "root": "root",
  "version": 7
}

File addition: doc (d--x------)
[2.1]

File addition: CHANGELOG.md (----------)

[0.83804]

# Revision history for kaos
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.

File addition: activitypuppy.cabal (----------)

[2.1]

cabal-version:      3.4
name:               activitypuppy
version:            0.1.0
-- synopsis:
-- description:
license:            MIT
license-file:       LICENSE
author:             Riley Ezri
maintainer:         me@riley.lgbt
-- copyright:
category:           Web
build-type:         Simple
extra-doc-files:    doc/CHANGELOG.md
-- extra-source-files:
common warnings
    ghc-options: -Wall
library
    import: warnings
    exposed-modules:
        Puppy.Config
        Puppy.Context
        Puppy.Crypto
        Puppy.Crypto.RNG
        Puppy.Crypto.RSA
        Puppy.Database
        Puppy.Logging
        Puppy.Protocol.ActivityPub
        Puppy.Protocol.ActivityPub.Fetch
        Puppy.Protocol.ActivityStreams
        Puppy.Protocol.WebFinger
        Puppy.TaskQueue
        Puppy.Files
        Puppy.Protocol.HTTP
        Puppy.Protocol.HTTP.Signature
        Puppy.Types
    build-depends:
        aeson,
        base ^>=4.17.0.0,
        base64,
        bytestring,
        cryptonite,
        cryptostore,
        directory,
        effectful,
        effectful-th,
        http-conduit,
        memory,
        sqlite-simple,
        text,
        time,
        uuid,
        vector,
        wai,
        warp,
        x509
    hs-source-dirs:   src/lib
    default-language: GHC2021
    default-extensions:
        DataKinds,
        TypeFamilies,
        LambdaCase,
        OverloadedRecordDot,
        OverloadedStrings
executable puppy-api
    import:           warnings
    main-is:          Main.hs
    default-extensions:
        DataKinds,
        TypeFamilies,
        LambdaCase,
        OverloadedRecordDot,
        OverloadedStrings
    other-modules:
        API.ActivityPub
        API.User
        API.WebFinger
        Data.Result
        Router
    build-depends:
        aeson,
        activitypuppy,
        base ^>=4.17.0.0,
        bytestring,
        cryptonite,
        cryptostore,
        directory,
        effectful,
        http-conduit,
        sqlite-simple,
        text,
        time,
        vector,
        uuid,
        warp,
        wai,
        x509
    hs-source-dirs:   src/app/api
    default-language: GHC2021
test-suite test
    import: warnings
    main-is: Spec.hs
    other-modules:
        Signatures
    hs-source-dirs: test
    type: exitcode-stdio-1.0
    default-extensions:
        DataKinds,
        TypeFamilies,
        LambdaCase,
        OverloadedRecordDot,
        OverloadedStrings
    build-depends:
        activitypuppy,
        base,
        cryptonite,
        effectful,
        hspec,
        QuickCheck,
        text,
        time
    default-language: GHC2021

File addition: README.md (----------)

[2.1]

# ActivityPuppy ✨
**Puppy, fetch my posts!**
ActivityPuppy is a federated microblogging server designed for small self-organizing and self-moderating 
groups, collectives and organizations, built on open protocols and mutual trust.
It is primarily intended to serve as a lightweight alternative to Mastodon, Akkoma and various forks
of Misskey for small groups of friends/comrades who trust each other to keep their community safe by
applying anarchist principles to moderation and administration.
## Project goals
ActivityPuppy aims to be an ActivityPub project explicitly incorporating anti-hierarchical, anti-centralization 
and self-organization practices.
At time of writing, governance of the Mastodon project, which in some ways sets the de facto standards
on the microbloggin fediverse, is centralized in such a way that it poses a threat to the safety of
many marginalized users on the platform. This project aims to counter this by providing an alternative
which takes decentralization as a tactic for preventing abuse seriously, and encourages the creation of
many smaller-scale communities as opposed to a few large and hard-to-moderate servers.
## Building and running
This project uses Nix and Cabal as build tools. Cabal is used for everyday development tasks such as testing,
whereas Nix is used to set up the development environment and package releases.
You can acquire a development shell by running the following command:
```
nix develop
```
A development build can be done as such:
```
cabal build
```
In order to start a development build of the server, use cabal:
```
cabal run
```
### Database "migrations"
Before you can do anything with the database, you should set it up using the `sqlite3` program:
```
sqlite3 .state/db.sqlite < sql/0000.up.sql
sqlite3 .state/db.sqlite < sql/0001.up.sql
```

File addition: LICENSE (----------)

[2.1]

Copyright (c) 2023 Riley Ezri
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

File addition: .ignore (----------)
[2.1]
```
.git
.DS_Store
```
File addition: .gitignore (----------)
[2.1]
```
dist-newstyle
.state
```

Initial change

Dependencies

In channels

Change contents

File addition: test (d--x------)

File addition: testKey (----------)

File addition: Spec.hs (----------)

File addition: Signatures.hs (----------)

File addition: src (d--x------)

File addition: lib (d--x------)

File addition: Puppy (d--x------)

File addition: Types.hs (----------)

File addition: TaskQueue.hs (----------)

File addition: Protocol (d--x------)

File addition: WebFinger.hs (----------)

File addition: HTTP.hs (----------)

File addition: HTTP (d--x------)

File addition: Signature.hs (----------)

File addition: ActivityStreams.hs (----------)

File addition: ActivityPub.hs (----------)

File addition: ActivityPub (d--x------)

File addition: Fetch.hs (----------)

File addition: Logging.hs (----------)

File addition: Files.hs (----------)

File addition: Database.hs (----------)

File addition: Crypto.hs (----------)

File addition: Crypto (d--x------)

File addition: RSA.hs (----------)

File addition: RNG.hs (----------)

File addition: Context.hs (----------)

File addition: Config.hs (----------)

File addition: Kaos (d--x------)

File addition: Protocol (d--x------)

File addition: ActivityPub (d--x------)

File addition: Resolve.hs (----------)

File addition: Deliver.hs (----------)

File addition: app (d--x------)

File addition: cli (d--x------)

File addition: Main.hs (----------)

File addition: api (d--x------)

File addition: Router.hs (----------)

File addition: Main.hs (----------)

File addition: Kaos (d--x------)

File addition: Task (d--x------)

File addition: Data (d--x------)

File addition: Result.hs (----------)

File addition: API (d--x------)

File addition: WebFinger.hs (----------)

File addition: User.hs (----------)

File addition: ActivityPub.hs (----------)

File addition: README.md (----------)

File addition: sql (d--x------)

File addition: 0001.up.sql (----------)

File addition: 0001.down.sql (----------)

File addition: 0000.up.sql (----------)

File addition: 0000.down.sql (----------)

File addition: res (d--x------)

File addition: favicon.png (----------)

File addition: package.nix (----------)

File addition: flake.nix (----------)

File addition: flake.lock (----------)

File addition: doc (d--x------)

File addition: CHANGELOG.md (----------)

File addition: activitypuppy.cabal (----------)

File addition: README.md (----------)

File addition: LICENSE (----------)

File addition: .ignore (----------)

File addition: .gitignore (----------)