From e6319aa6863f54f878ce12e64210c66576e0f7da Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 21 Aug 2024 20:17:52 +0300 Subject: [PATCH] Actor system typed methods + upgrade to LTS-22 + remove darcs dep - I upgraded the actor system (Control.Concurrent.Actor) to support typed per-actor methods with type-level names, parameter lists and return values - For extensible sum types, I decided to use the 'vary' package, while extensible product still uses 'HList' (other options are to get both from 'extensible' (Sum, Prod) or from 'vinyl' (Rec, CoRed)) - Since 'vary' is new, it uses GHC2021 and thus requires GHC 9 - So I decided to make the leap into upgrading to an LTS with GHC 9 - Vervis was at LTS 18, at first I tried 19 and 20 but there were dependency version problems, in particular I couldn't solve them for the 'darcs' package even when I switched to latest LTS which is 22 - So I decided it's time to do the long-waiting task of switching to calling-darcs-process instead of using darcs as a library All of this together creates a huge commit, but 3 big things are now solved :) --- src/Control/Concurrent/Actor.hs | 1473 ++++++++++++++--- src/Control/Monad/Trans/Except/Local.hs | 4 - src/Darcs/Local/Repository.hs | 78 +- src/Data/Aeson/Local.hs | 28 +- src/Data/List/Local.hs | 13 +- src/Data/ObjId.hs | 76 + src/Database/Persist/Local.hs | 12 +- src/Development/Darcs.hs | 411 +++++ src/{Data/Git/Local.hs => Development/Git.hs} | 20 +- src/Network/Git/Get.hs | 3 +- src/Network/Git/Put.hs | 3 +- .../Git/Transport/HTTP/Fetch/RefDiscovery.hs | 9 +- .../Git/Transport/HTTP/Fetch/UploadRequest.hs | 3 +- src/Vervis/API.hs | 21 +- src/Vervis/ActivityPub.hs | 4 +- src/Vervis/Actor.hs | 206 +-- src/Vervis/Actor/Deck.hs | 35 +- src/Vervis/Actor/Factory.hs | 39 +- src/Vervis/Actor/Group.hs | 35 +- src/Vervis/Actor/Loom.hs | 26 +- src/Vervis/Actor/Person.hs | 35 +- src/Vervis/Actor/Person/Client.hs | 5 +- src/Vervis/Actor/Project.hs | 35 +- src/Vervis/Actor/Repo.hs | 32 +- src/Vervis/Actor2.hs | 2 +- src/Vervis/Application.hs | 2 +- src/Vervis/Darcs.hs | 226 +-- src/Vervis/Data/Discussion.hs | 2 +- src/Vervis/Federation/Auth.hs | 7 +- src/Vervis/Fetch.hs | 6 +- src/Vervis/Foundation.hs | 11 +- src/Vervis/Git.hs | 5 +- src/Vervis/Handler/Client.hs | 5 +- src/Vervis/Handler/Repo.hs | 6 +- src/Vervis/Hook.hs | 70 +- src/Vervis/KeyFile.hs | 8 +- src/Vervis/Migration.hs | 18 +- src/Vervis/Migration/Entities.hs | 270 +-- src/Vervis/Migration/Model2016.hs | 2 +- src/Vervis/Migration/Model2018.hs | 2 +- src/Vervis/Migration/Model2019.hs | 2 +- src/Vervis/Migration/Model2020.hs | 2 +- src/Vervis/Migration/Model2022.hs | 2 +- src/Vervis/Migration/Model2023.hs | 2 +- src/Vervis/Migration/Model2024.hs | 2 +- src/Vervis/Migration/TH.hs | 11 +- src/Vervis/Persist/Actor.hs | 34 +- src/Vervis/Ssh.hs | 10 +- src/Vervis/Web/Actor.hs | 20 +- src/Vervis/Web/Collab.hs | 2 +- src/Vervis/Web/Darcs.hs | 14 +- src/Vervis/Web/Git.hs | 3 +- src/Web/ActivityPub.hs | 12 +- src/Web/ActivityPub/Internal.hs | 6 +- src/Web/Actor/Deliver.hs | 66 +- stack.yaml | 44 +- vervis.cabal | 25 +- 57 files changed, 2402 insertions(+), 1103 deletions(-) create mode 100644 src/Data/ObjId.hs create mode 100644 src/Development/Darcs.hs rename src/{Data/Git/Local.hs => Development/Git.hs} (96%) diff --git a/src/Control/Concurrent/Actor.hs b/src/Control/Concurrent/Actor.hs index 9da554d..6516400 100644 --- a/src/Control/Concurrent/Actor.hs +++ b/src/Control/Concurrent/Actor.hs @@ -24,37 +24,87 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE IncoherentInstances #-} +-- We use Symbol to allow easily referring to a method without needing to +-- define a type alias for it +-- +-- Thus, we rely on TypeApplications to specify the method rather than passing +-- a proxy, and this extension is required for GHC to let us defer type +-- inference to the call site. +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | An evolving actor programming library. Intended to become a separate +-- package from Vervis. Name suggestions are welcome! Since many actor-related +-- libraries already exist on Hackage. module Control.Concurrent.Actor - ( Next () - , Actor (..) - , ActorLaunch (..) + ( -- * Defining an actor interface + Signature (..) + , Method (..) + + -- * Defining a method handler + , HandlerSig + , handleMethod + , MethodHandler (..) + + -- * Implementing an actor , Stage (..) - , ActorRef () + , Actor (..) + , Next () + , ActorLaunch (..) + , TheaterFor () , ActFor () - , runActor + , MonadActor (..) , asksEnv - , Message (..) - , startTheater - , callIO - , call - , sendIO - , send - , sendManyIO - , sendMany - , spawnIO - , spawn + , done , doneAnd , stop + + -- * Calling actor methods + , ActorHasMethod + , callIO' + , sendIO' + , call' + , send' + , ActorMethodCall () + , call + , ActorMethodSend () + , send + + -- * Launching actors + , spawnIO + , spawn + + -- * Launching the actor system + , startTheater + + -- * Exported for use in constraints in Vervis.Actor + , ActorRef () + , Func + , AdaptedHandler + , AdaptedAction + , Parcel_ + , AdaptHandlerConstraint + , HAdaptHandler + , Handler_ + , Handle' + + -- * Exported to allow some Yesod Handlers to reuse some actor actions + , runActor + + + --, Message (..) + --, sendManyIO + --, sendMany ) where -import Data.HList (HList) +import Data.HList (HList (..)) import Data.Kind import Fcf import "first-class-families" Fcf.Data.Symbol @@ -64,7 +114,6 @@ import qualified Data.HList as H import Control.Concurrent import Control.Concurrent.STM.TVar import Control.Monad -import Control.Monad.Fail import Control.Monad.IO.Unlift import Control.Monad.Logger.CallStack import Control.Monad.STM @@ -75,88 +124,158 @@ import Control.Monad.Trans.Reader import Data.Foldable import Data.Hashable import Data.HashMap.Strict (HashMap) -import Data.HashSet (HashSet) import Data.Proxy import Data.Text (Text) import Data.Traversable +import GHC.TypeLits import UnliftIO.Exception import qualified Control.Exception.Annotated as AE import qualified Control.Monad.Trans.RWS.Lazy as RWSL import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS import qualified Data.Text as T +import qualified Vary as V import Control.Concurrent.Return --- PROBLEM: I'm stuck with how App can hold the (TheaterFor Env) while Env --- needs to somehow hold the route rendering function (Route App -> Text) so --- there's a cyclic reference +--------------------------- Defining method types ---------------------------- + +-- These are for Actor instances to define the actor's interface -- --- And right now the classes below are weird: +-- * An interface is a set of zero or more methods +-- * Each method has: +-- * A unique name +-- * A list of zero or more parameter types +-- * A return type + +-- A type-level representation of an actor method's signature. -- --- * Stage and Env terms used interchangeably, it's cnfusing, Stage is weird --- * The main type everything's keyed on is the Env, which is merely parameters --- for the actor, perhaps we can key on an abstact type where Env is just one --- of the things keyed on it? +-- >>> :k Int :-> String :-> Return Bool +-- Int :-> String :-> Return Bool :: Signature +data Signature = Return Type | Type :-> Signature + +infixr 1 :-> + +-- A named actor method, combines a signature with a type-level name string. -- --- And that change into abstract type can also help with the cyclic reference? +-- >>> :k "saveTheWorld" ::: Int :-> String :-> Return Bool +-- "saveTheWorld" ::: Int :-> String :-> Return Bool :: Method +data Method = Symbol ::: Signature -type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () +infix 0 ::: -data Next = Stop | Proceed +-- Getters to extract parameters and return type from a Signature -class Actor (a :: Type) where - type ActorStage a :: Type - type ActorKey a = (k :: Type) | k -> a - data ActorMessage a :: Type - type ActorReturn a :: Type +type SignatureParams :: Signature -> [Type] +type family SignatureParams s where + SignatureParams ('Return t) = '[] + SignatureParams (t ':-> sig) = t ': SignatureParams sig -class Actor a => ActorLaunch a where - actorBehavior - :: ActorKey a - -> ActorMessage a - -> ActFor - (ActorStage a) - (ActorReturn a, ActFor (ActorStage a) (), Next) +type SignatureReturn :: Signature -> Type +type family SignatureReturn s where + SignatureReturn ('Return t) = t + SignatureReturn (t ':-> sig) = SignatureReturn sig + +-- Method lookup support + +data MethodToPair :: Method -> Exp (Symbol, Signature) +type instance Eval (MethodToPair (sym ::: sig)) = '(sym, sig) + +data LookupSig :: Symbol -> [Method] -> Exp (Maybe Signature) +type instance Eval (LookupSig sym ms) = + Eval (Lookup sym (Eval (Map MethodToPair ms))) + +--------------------------- Defining method handlers ------------------------- + +-- TODO switch Proxy to SSymbol? + +type HandlerAction :: Type -> Type -> Type +type HandlerAction stage ret = ActFor stage (ret, ActFor stage (), Next) + +-- | With this setup: +-- +-- @ +-- type SaveTheWorld :: Signature +-- type SaveTheWorld = Int :-> String :-> Return Bool +-- +-- data World +-- instance Stage World where +-- ... +-- @ +-- +-- The type +-- +-- @ +-- HandlerSig World SaveTheWorld +-- @ +-- +-- Is the same as +-- +-- @ +-- Int -> String -> ActFor World Bool +-- @ +--type HandlerSig :: Type -> Signature -> Type +type family HandlerSig (stage :: Type) (signature :: Signature) = (a :: Type) | a -> stage signature where + HandlerSig s (Return t) = HandlerAction s t + HandlerSig s (t :-> sig) = t -> HandlerSig s sig + +-- Alias for 'Proxy'. See example in 'MethodHandler'. +handleMethod :: forall (sym :: Symbol) . Proxy sym +handleMethod = Proxy + +-- | Example: +-- +-- @ +-- type SaveTheWorld :: Signature +-- type SaveTheWorld = Int :-> String :-> Return Bool +-- +-- data Hero +-- instance Actor Hero where +-- ... +-- +-- handler :: MethodHandler Hero "saveTheWorld" SaveTheWorld +-- handler = +-- handleMethod @"saveTheWorld" := \ key num str = do +-- liftIO $ print key +-- liftIO $ print num +-- liftIO $ putStrLn str +-- liftIO $ putStrLn "Yay I saved the world" +-- done True +-- @ +data MethodHandler (actor :: Type) (sym :: Symbol) (sig :: Signature) = + Proxy sym := (ActorKey actor -> HandlerSig (ActorStage actor) sig) + +--------------------------- Implementing an actor ---------------------------- class Stage (a :: Type) where data StageEnv a :: Type type StageActors a :: [Type] -newtype ActorRef' m r = ActorRef' (Chan (m, Either SomeException r -> IO ())) +class Actor (a :: Type) where + type ActorStage a :: Type + type ActorKey a = (k :: Type) | k -> a + type ActorInterface a :: [Method] -newtype ActorRef a = ActorRef (ActorRef' (ActorMessage a) (ActorReturn a)) +data Next = Stop | Proceed -callIO'' :: ActorRef' m r -> m -> IO r -callIO'' (ActorRef' chan) msg = do - (returx, wait) <- newReturn - writeChan chan (msg, returx) - result <- wait - case result of - Left e -> AE.checkpointCallStack $ throwIO e - Right r -> return r +data Handler_ :: Type -> Method -> Exp Type +type instance Eval (Handler_ actor (sym ::: sig)) = MethodHandler actor sym sig -callIO' :: Actor a => ActorRef a -> ActorMessage a -> IO (ActorReturn a) -callIO' (ActorRef ref) = callIO'' ref +class Actor a => ActorLaunch a where + actorBehavior :: Proxy a -> HList (Eval (Map (Handler_ a) (ActorInterface a))) -sendIO'' :: ActorRef' m r -> m -> IO () -sendIO'' (ActorRef' chan) msg = writeChan chan (msg, const $ pure ()) - -sendIO' :: Actor a => ActorRef a -> ActorMessage a -> IO () -sendIO' (ActorRef ref) = sendIO'' ref +type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () type ActorRefMap a = HashMap (ActorKey a) (ActorRef a) -data Item_ :: Type -> Exp Type -type instance Eval (Item_ a) = TVar (ActorRefMap a) +data ActorRefMapTVar_ :: Type -> Exp Type +type instance Eval (ActorRefMapTVar_ a) = TVar (ActorRefMap a) -- | A set of live actors responding to messages data TheaterFor s = TheaterFor - { theaterMap :: HList (Eval (Map Item_ (StageActors s))) + { theaterMap :: HList (Eval (Map ActorRefMapTVar_ (StageActors s))) , theaterLog :: LogFunc } --- theaterMap :: TVar (HashMap (StageKey s) (ActorRef (StageMessage s) (StageReturn s))) -- | Actor monad in which message reponse actions are executed. Supports -- logging, a read-only environment, and IO. @@ -209,84 +328,874 @@ instance (Monoid w, MonadActor m) => MonadActor (RWSL.RWST r w s m) where asksEnv :: MonadActor m => (StageEnv (MonadActorStage m) -> a) -> m a asksEnv f = f <$> askEnv -class Message a where - summarize :: a -> Text - refer :: a -> Text +done :: Monad m => a -> m (a, ActFor s (), Next) +done msg = return (msg, return (), Proceed) + +doneAnd :: Monad m => a -> ActFor s () -> m (a, ActFor s (), Next) +doneAnd msg act = return (msg, act, Proceed) + +stop :: Monad m => a -> m (a, ActFor s (), Next) +stop msg = return (msg, return (), Stop) + +--------------------------- Actor queue internals ---------------------------- + +-- The actual message inserted into an actor's queue +-- +-- For example, given this signature: +-- +-- @ +-- type SaveTheWorld :: Signature +-- type SaveTheWorld = Int :-> String :-> Return Bool +-- @ +-- +-- We could do the following (a bit silly example, the functions @sendBool@ and +-- @sendString@ don't really exist, they're just for the sake of the example): +-- +-- @ +-- parcel :: Parcel SaveTheWorld +-- parcel = Parcel +-- { +-- -- HList [Int, String] +-- _parcelParams = 5 `H.HCons` "cool" `H.HCons` H.HNil +-- +-- -- Either SomeException Bool -> IO () +-- , _parcelReturn = \case +-- Left e -> sendString $ displayException e +-- Right b -> +-- if b +-- then sendBool True +-- else sendBool False +-- } +-- @ + +data Parcel (s :: Signature) = Parcel + { _parcelParams :: HList (SignatureParams s) + , _parcelReturn :: Either SomeException (SignatureReturn s) -> IO () + } + +-- Given a method, denotes a pair of: +-- +-- * 'Proxy' to witness the method's name +-- * 'Parcel' to hold the actual data required for invoking the method +-- +-- Given a method +-- +-- @ +-- type SaveTheWorld :: Method +-- type SaveTheWorld = "saveTheWorld" ::: Int :-> String :-> Return Bool +-- @ +-- +-- We could do the following: +-- +-- @ +-- parcel :: Eval (Parcel_ SaveTheWorld) +-- parcel = +-- ( Proxy@"saveTheWorld" +-- , Parcel +-- { +-- -- HList [Int, String] +-- _parcelParams = ... +-- +-- -- Either SomeException Bool -> IO () +-- , _parcelReturn = ... +-- } +-- ) +-- @ + +data Parcel_ :: Method -> Exp Type +type instance Eval (Parcel_ (sym '::: sig)) = (Proxy sym, Parcel sig) + +-- The actual type of items in the actor's message queue, since an actor can +-- have multiple methods + +newtype Invocation (ms :: [Method]) = Invocation + { _unInvocation :: V.Vary (Eval (Map Parcel_ ms)) + } + +-- A reference to a live actor holds its message queue, so that we can insert a +-- new message to it + +newtype ActorRef' (ms :: [Method]) = ActorRef' + { _unActorRef' :: Chan (Invocation ms) + } + +newtype ActorRef (a :: Type) = ActorRef + { _unActorRef :: ActorRef' (ActorInterface a) + } + +--------------------------- Calling a method --------------------------------- + +-- invokeMethod and invokeMethod_ are the building blocks for calling actor +-- methods. They simply take an HList of parameters, and a reference to the +-- actor message queue. +-- +-- All the high-level wrappers are built on top of these two functions. + +invokeMethod' + :: forall + (m::Method) + (ms::[Method]) + (sym::Symbol) + (sig::Signature) . + ( m ~ (sym ::: sig) + , Eval (Parcel_ m) V.:| Eval (Map Parcel_ ms) + ) + => Proxy m + -> HList (SignatureParams sig) + -> ActorRef' ms + -> IO (SignatureReturn sig) +invokeMethod' proxy args (ActorRef' chan) = do + (sendResult, waitResult) <- newReturn + let parcel = Parcel args sendResult :: Parcel sig + inv = Invocation $ V.from (p proxy, parcel) + writeChan chan inv + result <- waitResult + case result of + Left e -> AE.checkpointCallStack $ throwIO e + Right r -> return r + where + p :: Proxy (symbol ::: signat) -> Proxy symbol + p _ = Proxy + +invokeMethod + :: forall + (a::Type) + (m::Method) + (sym::Symbol) + (sig::Signature) . + ( Actor a + , m ~ (sym ::: sig) + , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) + ) + -- => Proxy sym + => Proxy m + -> HList (SignatureParams sig) + -> ActorRef a + -> IO (SignatureReturn sig) +invokeMethod proxy args (ActorRef ref) = invokeMethod' (id proxy) args ref +{- + where + p :: Proxy sym -> Proxy m + p _ = Proxy +-} + +invokeMethod_' + :: forall + (m::Method) + (ms::[Method]) + (sym::Symbol) + (sig::Signature) . + ( m ~ (sym ::: sig) + , Eval (Parcel_ m) V.:| Eval (Map Parcel_ ms) + ) + => Proxy m + -> HList (SignatureParams sig) + -> ActorRef' ms + -> IO () +invokeMethod_' proxy args (ActorRef' chan) = do + let sendResult = const $ pure () + parcel = Parcel args sendResult :: Parcel sig + inv = Invocation $ V.from (p proxy, parcel) + writeChan chan inv + where + p :: Proxy (symbol ::: signat) -> Proxy symbol + p _ = Proxy + +invokeMethod_ + :: forall + (a::Type) + (m::Method) + (sym::Symbol) + (sig::Signature) . + ( Actor a + , m ~ (sym ::: sig) + , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) + ) + -- => Proxy sym + => Proxy m + -> HList (SignatureParams sig) + -> ActorRef a + -> IO () +invokeMethod_ proxy args (ActorRef ref) = invokeMethod_' (id proxy) args ref +{- + where + p :: Proxy sym -> Proxy m + p _ = Proxy +-} + +-- One level higher, instead of holding an ActorRef, i.e. the actor message +-- queue, we hold a Theater and an ActorKey, and we need to lookup the actor's +-- message queue in the Theater +-- +-- 'callIO\'' and 'sendIO\'' are exported, for Vervis to use, but will likely +-- be hidden/removed in the future. +-- +-- They allow to invoke a method from outside of an actor context. This is +-- possible right now, but as the library evolves and gains complexity, they're +-- likely to be removed. +-- +-- Right now it allows the Vervis actor inbox POST handlers to insert +-- activities into actor queues. + +askTheater :: ActFor s (TheaterFor s) +askTheater = ActFor $ lift $ asks snd + +lookupActor + :: ( Eq (ActorKey a), Hashable (ActorKey a) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) + ) + => TheaterFor s + -> ActorKey a + -> IO (Maybe (ActorRef a)) +lookupActor (TheaterFor hlist _) key = + HM.lookup key <$> readTVarIO (H.hOccurs hlist) + +{- +class Actor a => IsActorMethod (sym::Symbol) (a::Type) where + type ActorMethod sym a = (sig :: Signature) | sym a -> sig +instance +-} + +type ActorHasMethod :: Type -> Symbol -> Signature -> Constraint +type family ActorHasMethod actor symbol signature where + ActorHasMethod a sym sig = + ( Eval (LookupSig sym (ActorInterface a)) ~ Just sig + , Eval (Parcel_ (sym ::: sig)) V.:| Eval (Map Parcel_ (ActorInterface a)) + ) + +-- | Same as 'call\'', except it takes the theater as a parameter, as well as a +-- Proxy specifying the method's name. +-- +-- This function allows to invoke a method from outside of an actor context. +-- This is possible right now, but as the library evolves and gains complexity, +-- this function might be removed. +-- +-- Right now it allows the Vervis actor inbox POST handlers to insert +-- activities into actor queues. +callIO' + :: forall + (sym::Symbol) + (a::Type) + (m::Method) + (sig::Signature) + (stage::Type) . + ( Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + , m ~ (sym ::: sig) + --, Eval (LookupSig sym (ActorInterface a)) ~ Just sig + --, Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) + , ActorHasMethod a sym sig + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors stage)))) + ) + => TheaterFor stage + -> Proxy m + -> ActorKey a + -> HList (SignatureParams sig) + -> IO (Maybe (SignatureReturn sig)) +callIO' theater proxy key args = do + maybeRef <- lookupActor theater key + for maybeRef $ \ ref -> invokeMethod proxy args ref + +-- | Same as 'send\'', except it takes the theater as a parameter, as well as a +-- Proxy specifying the method's name. +-- +-- This function allows to invoke a method from outside of an actor context. +-- This is possible right now, but as the library evolves and gains complexity, +-- this function might be removed. +-- +-- Right now it allows the Vervis actor inbox POST handlers to insert +-- activities into actor queues. +sendIO' + :: forall + (sym::Symbol) + (a::Type) + (m::Method) + (sig::Signature) + (stage::Type) . + ( Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + , m ~ (sym ::: sig) + , Eval (LookupSig sym (ActorInterface a)) ~ Just sig + , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors stage)))) + ) + => TheaterFor stage + -> Proxy m + -> ActorKey a + -> HList (SignatureParams sig) + -> IO Bool +sendIO' theater proxy key args = do + maybeRef <- lookupActor theater key + case maybeRef of + Nothing -> return False + Just ref -> do + invokeMethod_ proxy args ref + return True + +-- Another level higher, we're now in an actor context, grabbing the Theater +-- from the context rather than passing it as a parameter. +-- +-- Otherwise we're still using an HList and a Proxy. + +-- | Like 'call', except a Proxy is passed to specify the method's name, and +-- arguments are passed as a 'HList'. +call' + :: forall + (sym::Symbol) + (a::Type) + (m::Method) + (sig::Signature) + (stage::Type) + (monad :: Type -> Type) . + ( Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + , m ~ (sym ::: sig) + , Eval (LookupSig sym (ActorInterface a)) ~ Just sig + , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors stage)))) + , stage ~ ActorStage a + , MonadActor monad + , MonadActorStage monad ~ stage + ) + => Proxy m + -> ActorKey a + -> HList (SignatureParams sig) + -> monad (Maybe (SignatureReturn sig)) +call' proxy key args = liftActor $ do + theater <- askTheater + liftIO $ callIO' theater proxy key args + +-- | Like 'send', except a Proxy is passed to specify the method's name, and +-- arguments are passed as a 'HList'. +send' + :: forall + (sym::Symbol) + (a::Type) + (m::Method) + (sig::Signature) + (stage::Type) + (monad :: Type -> Type) . + ( Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + , m ~ (sym ::: sig) + , Eval (LookupSig sym (ActorInterface a)) ~ Just sig + , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors stage)))) + , stage ~ ActorStage a + , MonadActor monad + , MonadActorStage monad ~ stage + ) + => Proxy m + -> ActorKey a + -> HList (SignatureParams sig) + -> monad Bool +send' proxy key args = liftActor $ do + theater <- askTheater + liftIO $ sendIO' theater proxy key args + +-- We now have 2 things to add, for pretty syntax: +-- +-- * Allowing to pass arguments as regular function arguments, instead of an +-- HList +-- * Remove the (Proxy m) and rely on TypeApplications (I tried a middle step +-- of using (Proxy sym) but inference fails, so we'd need TypeApplications +-- either way) +-- +-- I can't tell which one makes more sense to add first, so another level +-- higher we're now just adding both at the same time. + +------ TODO if the code below fails: +-- +-- Maybe a problem will be that even if we give 'sym' via TypeApplications, +-- 'sig' and 'm' can't be inferred because the only thing that suggests what +-- they are is the V.:| constraint. Instead, given 'sym', we need to do a +-- lookup in 'ms', which will determine 'm' and 'sig' +-- +-- We can use the 'CallSig' family for help here. +-- +-- There's also hCurry/hUncurry from HList + +type family CallSig (stage :: Type) (signature :: Signature) = (a :: Type) | a -> stage signature where + CallSig s (Return t) = ActFor s (Maybe t) + CallSig s (t :-> sig) = t -> CallSig s sig + +class ActorMethodCall (sym :: Symbol) (actor :: Type) (params :: [Type]) (result :: Type) where + actorMethodCall :: ActorKey actor -> HList params -> result + +instance + forall + (sym::Symbol) + (a::Type) + (m::Method) + (sig::Signature) + (ret::Type) + (stage::Type) + (monad :: Type -> Type) + (params :: [Type]) + (paramsRev :: [Type]) . + ( Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + , Eval (LookupSig sym (ActorInterface a)) ~ Just sig + , m ~ (sym ::: sig) + , ret ~ SignatureReturn sig + , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors stage)))) + , stage ~ ActorStage a + , MonadActor monad + , MonadActorStage monad ~ stage + , params ~ SignatureParams sig + , H.HReverse paramsRev params + ) => + ActorMethodCall sym a paramsRev (monad (Maybe ret)) where + actorMethodCall key argsRev = + let args = H.hReverse argsRev :: HList params + in call' (Proxy @m) key args + +instance ActorMethodCall sym actor (x:xs) r => ActorMethodCall sym actor xs (x -> r) where + actorMethodCall key args = \ arg -> actorMethodCall @sym key (arg `H.HCons` args) + +-- | Send a message to an actor, and wait for the result to arrive. Return +-- 'Nothing' if actor doesn't exist, otherwise 'Just' the result. +-- +-- If the called method throws an exception, it is rethrown, wrapped with an +-- annotation, in the current thread. +-- +-- @ +-- call \@"saveTheWorld" heroID 5 "hello" :: ActFor World (Maybe Bool) +-- @ +call + :: forall (sym :: Symbol) (actor :: Type) (r :: Type) (sig :: Signature) . + ( ActorMethodCall sym actor '[] r + , Eval (LookupSig sym (ActorInterface actor)) ~ Just sig + , r ~ CallSig (ActorStage actor) sig + ) + => ActorKey actor + -> r +call key = actorMethodCall @sym key HNil + +type family SendSig (stage :: Type) (signature :: Signature) = (a :: Type) | a -> stage where + SendSig s (Return t) = ActFor s Bool + SendSig s (t :-> sig) = t -> SendSig s sig + +class ActorMethodSend (sym :: Symbol) (actor :: Type) (params :: [Type]) (result :: Type) where + actorMethodSend :: ActorKey actor -> HList params -> result + +instance + forall + (sym::Symbol) + (a::Type) + (m::Method) + (sig::Signature) + (stage::Type) + (monad :: Type -> Type) + (params :: [Type]) + (paramsRev :: [Type]) . + ( Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + , Eval (LookupSig sym (ActorInterface a)) ~ Just sig + , m ~ (sym ::: sig) + , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors stage)))) + , stage ~ ActorStage a + , MonadActor monad + , MonadActorStage monad ~ stage + , params ~ SignatureParams sig + , H.HReverse paramsRev params + ) => + ActorMethodSend sym a paramsRev (monad Bool) where + actorMethodSend key argsRev = + let args = H.hReverse argsRev :: HList params + in send' (Proxy @m) key args + +instance ActorMethodSend sym actor (x:xs) r => ActorMethodSend sym actor xs (x -> r) where + actorMethodSend key args = \ arg -> actorMethodSend @sym key (arg `H.HCons` args) + +-- | Send a message to an actor, without waiting for a result. Return 'True' if +-- the given actor exists, 'False' otherwise. +-- +-- If the called method throws an exception, it is rethrown, wrapped with an +-- annotation, in the current thread. +-- +-- @ +-- send \@"saveTheWorld" heroID 5 "hello" :: ActFor World Bool +-- @ +send + :: forall (sym :: Symbol) (actor :: Type) (r :: Type) (sig :: Signature) . + ( ActorMethodSend sym actor '[] r + , Eval (LookupSig sym (ActorInterface actor)) ~ Just sig + , r ~ SendSig (ActorStage actor) sig + ) + => ActorKey actor + -> r +send key = actorMethodSend @sym key HNil + +--------------------------- Launching actors --------------------------------- + +-- We first need a way to apply a given HList as arguments to a given function, +-- which is the method handler. I think I managed to write a simple +-- implementation! But just in case, HList's HCurry is also available. + +class UncurryH xs g r where + uncurryH :: g -> HList xs -> r + +instance UncurryH xs y r => UncurryH (x:xs) (x -> y) r where + uncurryH g (HCons x xs) = uncurryH (g x) xs + +instance UncurryH '[] a a where + uncurryH x HNil = x + +-- Now let's try to implement a generic handler +-- +-- Note that this handler is order-based, relying that the parameter types in +-- the Vary and the handler types in the HList match. +-- +-- But it's possible for different methods to have the same signature! +-- +-- So just in case, to reduce the risk of uncaught confusions here, let's see +-- if we can combine method names into this. + +data Func :: Type -> Type -> Exp Type +type instance Eval (Func b a) = a -> b + +class Handle' xs r where + handle' :: V.Vary xs -> HList (Eval (Map (Func r) xs)) -> r + +instance Handle' '[] r where + handle' vary HNil = V.exhaustiveCase vary + +instance Handle' xs r => Handle' (x:xs) r where + handle' vary (HCons f fs) = + case V.pop vary of + Left vary' -> handle' vary' fs + Right arg -> f arg + +matchAdaptedHandler + :: forall (stage::Type) (ms::[Method]) . + ( Eval (Map (Func (AdaptedAction stage, Text)) (Eval (Map Parcel_ ms))) + ~ + Eval (Map (AdaptedHandler stage) ms) + , Handle' + (Eval (Map Parcel_ ms)) + (AdaptedAction stage, Text) + ) + => V.Vary (Eval (Map Parcel_ ms)) + -> HList (Eval (Map (AdaptedHandler stage) ms)) + -> (AdaptedAction stage, Text) +matchAdaptedHandler = handle' + +-- Now, how we turn the pretty human-defined 'MethodHandler' into the input +-- that handle' expects? Let's try. + +uncurryHandler + :: UncurryH + (SignatureParams sig) + (HandlerSig stage sig) + (HandlerAction stage (SignatureReturn sig)) + => HandlerSig stage sig + -> HList (SignatureParams sig) + -> HandlerAction stage (SignatureReturn sig) +uncurryHandler = uncurryH + +adaptHandler + :: ( ActorStage actor ~ stage + , Show (ActorKey actor) + , KnownSymbol sym + , UncurryH + (SignatureParams sig) + (HandlerSig stage sig) + (HandlerAction stage (SignatureReturn sig)) + ) + => ActorKey actor + -> MethodHandler actor sym sig + -> (Proxy sym, Parcel sig) + -> (AdaptedAction (ActorStage actor), Text) +adaptHandler key (Proxy := handler) (p@Proxy, Parcel args respond) = + (go, prefixOn) + where + prefix = T.concat ["[Actor '", T.pack $ show key, "']"] + prefixOn = T.concat [prefix, " on ", T.pack $ symbolVal p] + go = do + result <- try $ uncurryHandler (handler key) args + case result of + Left e -> do + logError $ T.concat [prefix, " exception: ", T.pack $ displayException (e :: SomeException)] + liftIO $ respond $ Left e + return Nothing + Right (value, after, next) -> do + logInfo $ T.concat [prefix, " result"] --, T.pack $ show value] + liftIO $ respond $ Right value + return $ Just (after, next) + +-- This is for adaptHandler to work with hMapL + +data HAdaptHandler a = HAdaptHandler (ActorKey a) + +instance + ( ActorStage actor ~ stage + , Show (ActorKey actor) + , KnownSymbol sym + , UncurryH + (SignatureParams sig) + (HandlerSig stage sig) + (HandlerAction stage (SignatureReturn sig)) + , i ~ MethodHandler actor sym sig + , o ~ ( (Proxy sym, Parcel sig) -> (AdaptedAction stage, Text) ) + ) => + H.ApplyAB (HAdaptHandler actor) i o where + applyAB (HAdaptHandler key) = adaptHandler key + +data AdaptHandlerConstraint :: Type -> Method -> Exp Constraint +type instance Eval (AdaptHandlerConstraint actor (sym ::: sig)) = + ( Show (ActorKey actor) + , KnownSymbol sym + , UncurryH + (SignatureParams sig) + (HandlerSig (ActorStage actor) sig) + (HandlerAction (ActorStage actor) (SignatureReturn sig)) + ) + +type AdaptedAction :: Type -> Type +type AdaptedAction stage = ActFor stage (Maybe (ActFor stage (), Next)) + +data AdaptedHandler :: Type -> Method -> Exp Type +type instance Eval (AdaptedHandler stage (sym ::: sig)) = + (Proxy sym, Parcel sig) -> (AdaptedAction stage, Text) launchActorThread - :: forall (a::Type) (k::Type) (m::Type) (r::Type) (s::Type). + :: forall (a::Type) (k::Type) (s::Type) (ms::[Method]) . ( ActorLaunch a , ActorStage a ~ s - , ActorKey a ~ k, ActorMessage a ~ m, ActorReturn a ~ r + , ActorKey a ~ k + , ActorInterface a ~ ms + , Eq k, Hashable k, Show k , H.HOccurs (TVar (ActorRefMap a)) - (HList (Eval (Map Item_ (StageActors s)))) - , Eq k, Hashable k, Show k, Message m, Show r + (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) + , Eval (Map (AdaptedHandler s) ms) + ~ + Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + , H.SameLength' + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + (Eval (Map (Handler_ a) ms)) + , H.SameLength' + (Eval (Map (Handler_ a) ms)) + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms))) + , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text) + , H.HMapAux + HList + (HAdaptHandler a) + (Eval (Map (Handler_ a) ms)) + (Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + ) ) - => Chan (m, Either SomeException r -> IO ()) + => Chan (Invocation ms) -> TheaterFor s -> k -> StageEnv s -> IO () launchActorThread chan theater actor env = void $ forkIO $ runActor theater env $ do - logInfo $ prefix <> "starting" - loop - logInfo $ prefix <> "bye" + let handlers' = H.hMapL (HAdaptHandler actor) handlers :: HList (Eval (Map (AdaptedHandler s) ms)) + logInfo $ prefix <> " starting" + loop handlers' + logInfo $ prefix <> " bye" where - prefix = T.concat ["[Actor '", T.pack $ show actor, "'] "] - loop = do - (message, respond) <- liftIO $ readChan chan - logInfo $ T.concat [prefix, "received: ", summarize message] - result <- try $ behavior (actorProxy actor) actor message + handlers :: HList (Eval (Map (Handler_ a) ms)) + handlers = actorBehavior (Proxy @a) + + prefix = T.concat ["[Actor '", T.pack $ show actor, "']"] + + loop :: HList (Eval (Map (AdaptedHandler s) ms)) -> ActFor s () + loop handlers' = do + Invocation vary <- liftIO $ readChan chan + let (run, prefixOn) = matchAdaptedHandler @s @ms vary handlers' :: (AdaptedAction s, Text) + logInfo $ T.concat [prefixOn, " received"] + result <- run proceed <- case result of - Left e -> do - logError $ T.concat [prefix, "on ", refer message, " exception: ", T.pack $ displayException (e :: SomeException)] - liftIO $ respond $ Left e - return True - Right (value, after, next) -> do - logInfo $ T.concat [prefix, "on ", refer message, " result: ", T.pack $ show value] - liftIO $ respond $ Right value + Nothing -> pure True + Just (after, next) -> do after case next of Stop -> do - logInfo $ T.concat [prefix, "on ", refer message, " stopping"] + logInfo $ T.concat [prefixOn, " stopping"] let tvar = H.hOccurs (theaterMap theater) :: TVar (ActorRefMap a) liftIO $ atomically $ modifyTVar' tvar $ HM.delete actor return False Proceed -> do - logInfo $ T.concat [prefix, "on ", refer message, " done"] + logInfo $ T.concat [prefixOn, " done"] return True - when proceed loop - actorProxy :: forall a. ActorKey a -> Proxy a - actorProxy _ = Proxy - behavior - :: Proxy a - -> ActorKey a - -> ActorMessage a - -> ActFor - (ActorStage a) - (ActorReturn a, ActFor (ActorStage a) (), Next) - behavior _ = actorBehavior + when proceed $ loop handlers' ---data HFind :: Type -> [Type] -> Maybe Type ---type instance Eval (HFind a as) = Eval (Find (TyEq a) as) :: Exp (Maybe a) - -prepareActorType - :: ( ActorLaunch a - , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) - , Message (ActorMessage a) - , Show (ActorReturn a) +-- | Same as 'spawn', except it takes the theater as a parameter. +spawnIO + :: forall (a::Type) (k::Type) (s::Type) (ms::[Method]) . + ( ActorLaunch a , ActorStage a ~ s - , Stage s + , ActorKey a ~ k + , ActorInterface a ~ ms + , Eq k, Hashable k, Show k , H.HOccurs (TVar (ActorRefMap a)) - (HList (Eval (Map Item_ (StageActors s)))) + (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) + , Eval (Map (AdaptedHandler s) ms) + ~ + Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + , H.SameLength' + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + (Eval (Map (Handler_ a) ms)) + , H.SameLength' + (Eval (Map (Handler_ a) ms)) + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms))) + , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text) + , H.HMapAux + HList + (HAdaptHandler a) + (Eval (Map (Handler_ a) ms)) + (Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + ) ) - => [(ActorKey a, StageEnv s)] + => TheaterFor s + -> ActorKey a + -> IO (StageEnv s) + -> IO Bool +spawnIO theater@(TheaterFor hlist _) key mkEnv = do + let tvar = H.hOccurs hlist :: TVar (ActorRefMap a) + chan <- newChan + added <- atomically $ stateTVar tvar $ \ hm -> + let hm' = HM.alter (create $ ActorRef $ ActorRef' chan) key hm + in ( not (HM.member key hm) && HM.member key hm' + , hm' + ) + when added $ do + env <- mkEnv + launchActorThread chan theater key env + return added + where + create actor Nothing = Just actor + create _ j@(Just _) = j + +-- | Launch a new actor with the given ID and behavior. Return 'True' if the ID +-- was unused and the actor has been launched. Return 'False' if the ID is +-- already in use, thus a new actor hasn't been launched. +spawn + :: forall (m::Type->Type) (a::Type) (k::Type) (s::Type) (ms::[Method]) . + ( MonadActor m, MonadActorStage m ~ s + , ActorLaunch a + , ActorStage a ~ s + , ActorKey a ~ k + , ActorInterface a ~ ms + , Eq k, Hashable k, Show k + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) + , Eval (Map (AdaptedHandler s) ms) + ~ + Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + , H.SameLength' + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + (Eval (Map (Handler_ a) ms)) + , H.SameLength' + (Eval (Map (Handler_ a) ms)) + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms))) + , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text) + , H.HMapAux + HList + (HAdaptHandler a) + (Eval (Map (Handler_ a) ms)) + (Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + ) + ) + => ActorKey a + -> IO (StageEnv s) + -> m Bool +spawn key mkEnv = liftActor $ do + theater <- askTheater + liftIO $ spawnIO theater key mkEnv + +--------------------------- Launching the actor system ----------------------- + +prepareActorType + :: forall (a::Type) (k::Type) (s::Type) (ms::[Method]) . + ( ActorLaunch a + , ActorStage a ~ s + , ActorKey a ~ k + , ActorInterface a ~ ms + , Eq k, Hashable k, Show k + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) + , Eval (Map (AdaptedHandler s) ms) + ~ + Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + , H.SameLength' + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + (Eval (Map (Handler_ a) ms)) + , H.SameLength' + (Eval (Map (Handler_ a) ms)) + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms))) + , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text) + , H.HMapAux + HList + (HAdaptHandler a) + (Eval (Map (Handler_ a) ms)) + (Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + ) + , Stage s + ) + => [(k, StageEnv s)] -> IO ( TVar (ActorRefMap a) , TheaterFor s -> IO () @@ -308,29 +1217,79 @@ prepareActorType actors = do data HPrepareActorType = HPrepareActorType instance + forall (a::Type) (k::Type) (s::Type) (ms::[Method]) (i::Type) (o::Type). ( ActorLaunch a - , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) - , Message (ActorMessage a) - , Show (ActorReturn a) , ActorStage a ~ s - , Stage s + , ActorKey a ~ k + , ActorInterface a ~ ms + , Eq k, Hashable k, Show k , H.HOccurs - (TVar (ActorRefMap a)) - (HList (Eval (Map Item_ (StageActors s)))) - , i ~ [(ActorKey a, StageEnv s)] - , o ~ IO (TVar (ActorRefMap a), TheaterFor (ActorStage a) -> IO ()) + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) + , Eval (Map (AdaptedHandler s) ms) + ~ + Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + , H.SameLength' + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + (Eval (Map (Handler_ a) ms)) + , H.SameLength' + (Eval (Map (Handler_ a) ms)) + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms))) + , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text) + , H.HMapAux + HList + (HAdaptHandler a) + (Eval (Map (Handler_ a) ms)) + (Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + ) + , Stage s + , i ~ [(k, StageEnv s)] + , o ~ IO (TVar (ActorRefMap a), TheaterFor s -> IO ()) ) => H.ApplyAB HPrepareActorType i o where applyAB _ a = prepareActorType a ---Why can't the compiler prove the HOccurence? Because it can't detect the l'? - data A_ :: Type -> Exp Constraint type instance Eval (A_ a) = ( ActorLaunch a , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) - , Message (ActorMessage a) - , Show (ActorReturn a) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors (ActorStage a))))) + , Eval (Map (AdaptedHandler (ActorStage a)) (ActorInterface a)) + ~ + Eval + (Map + (Func (AdaptedAction (ActorStage a), Text)) + (Eval (Map Parcel_ (ActorInterface a))) + ) + , H.SameLength' + (Eval (Map (Func (AdaptedAction (ActorStage a), Text)) (Eval (Map Parcel_ (ActorInterface a))))) + (Eval (Map (Handler_ a) (ActorInterface a))) + , H.SameLength' + (Eval (Map (Handler_ a) (ActorInterface a))) + (Eval (Map (Func (AdaptedAction (ActorStage a), Text)) (Eval (Map Parcel_ (ActorInterface a))))) + , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) (ActorInterface a)))) + , Handle' (Eval (Map Parcel_ (ActorInterface a))) (AdaptedAction (ActorStage a), Text) + , H.HMapAux + HList + (HAdaptHandler a) + (Eval (Map (Handler_ a) (ActorInterface a))) + (Eval + (Map + (Func (AdaptedAction (ActorStage a), Text)) + (Eval (Map Parcel_ (ActorInterface a))) + ) + ) ) data Starter :: Type -> Exp Type @@ -370,11 +1329,11 @@ startTheater (Eval (Map (Pair_ s) as)) , H.SameLength' - (Eval (Map Item_ as)) + (Eval (Map ActorRefMapTVar_ as)) (Eval (Map (Launch_ s) as)) , H.SameLength' (Eval (Map (Launch_ s) as)) - (Eval (Map Item_ as)) + (Eval (Map ActorRefMapTVar_ as)) , H.SameLength' (Eval (Map (Launch_ s) as)) @@ -384,7 +1343,7 @@ startTheater (Eval (Map (Launch_ s) as)) , H.HZipList - (Eval (Map Item_ as)) + (Eval (Map ActorRefMapTVar_ as)) (Eval (Map (Launch_ s) as)) (Eval (Map (Pair_ s) as)) @@ -398,95 +1357,62 @@ startTheater startTheater logFunc actors = do let actions = H.hMapL HPrepareActorType actors :: HList (Eval (Map (Prepare_ s) as)) mapsAndLaunches <- H.hSequence actions :: IO (HList (Eval (Map (Pair_ s) as))) - let (maps :: HList (Eval (Map Item_ as)), launches :: HList (Eval (Map (Launch_ s) as))) = H.hUnzip mapsAndLaunches + let (maps :: HList (Eval (Map ActorRefMapTVar_ as)), launches :: HList (Eval (Map (Launch_ s) as))) = H.hUnzip mapsAndLaunches theater = TheaterFor maps logFunc for_ (H.hList2List launches) $ \ launch -> launch theater return theater -askTheater :: ActFor s (TheaterFor s) -askTheater = ActFor $ lift $ asks snd - -lookupActor - :: ( Eq (ActorKey a), Hashable (ActorKey a) - , H.HOccurs - (TVar (ActorRefMap a)) - (HList (Eval (Map Item_ (StageActors s)))) - ) - => TheaterFor s - -> ActorKey a - -> IO (Maybe (ActorRef a)) -lookupActor (TheaterFor hlist _) key = - HM.lookup key <$> readTVarIO (H.hOccurs hlist) --- | Same as 'call', except it takes the theater as a parameter. -callIO - :: ( Actor a - , Eq (ActorKey a), Hashable (ActorKey a) - , H.HOccurs - (TVar (ActorRefMap a)) - (HList (Eval (Map Item_ (StageActors s)))) - ) - => TheaterFor s -> ActorKey a -> ActorMessage a -> IO (Maybe (ActorReturn a)) -callIO theater key msg = do - maybeActor <- lookupActor theater key - for maybeActor $ \ actor -> callIO' actor msg --- | Send a message to an actor, and wait for the result to arrive. Return --- 'Nothing' if actor doesn't exist, otherwise 'Just' the result. + + + + + + + + +--newtype HandlerSet (ms :: [Method]) + + + + + + + +-- PROBLEM: I'm stuck with how App can hold the (TheaterFor Env) while Env +-- needs to somehow hold the route rendering function (Route App -> Text) so +-- there's a cyclic reference -- --- If the called method throws an exception, it is rethrown, wrapped with an --- annotation, in the current thread. -call - :: ( MonadActor m, MonadActorStage m ~ ActorStage a - , Actor a - , Eq (ActorKey a), Hashable (ActorKey a) - , H.HOccurs - (TVar (ActorRefMap a)) - (HList (Eval (Map Item_ (StageActors (ActorStage a))))) - ) - => ActorKey a -> ActorMessage a -> m (Maybe (ActorReturn a)) -call key msg = liftActor $ do - theater <- askTheater - liftIO $ callIO theater key msg +-- And right now the classes below are weird: +-- +-- * Stage and Env terms used interchangeably, it's cnfusing, Stage is weird +-- * The main type everything's keyed on is the Env, which is merely parameters +-- for the actor, perhaps we can key on an abstact type where Env is just one +-- of the things keyed on it? +-- +-- And that change into abstract type can also help with the cyclic reference? + + + + + + + +--data HFind :: Type -> [Type] -> Maybe Type +--type instance Eval (HFind a as) = Eval (Find (TyEq a) as) :: Exp (Maybe a) + +{- + --- | Like 'send', except it takes the theater as a parameter. -sendIO - :: ( Actor a - , Eq (ActorKey a), Hashable (ActorKey a) - , H.HOccurs - (TVar (ActorRefMap a)) - (HList (Eval (Map Item_ (StageActors s)))) - ) - => TheaterFor s -> ActorKey a -> ActorMessage a -> IO Bool -sendIO theater key msg = do - maybeActor <- lookupActor theater key - case maybeActor of - Nothing -> return False - Just actor -> do - sendIO' actor msg - return True --- | Send a message to an actor, without waiting for a result. Return 'True' if --- the given actor exists, 'False' otherwise. -send - :: ( MonadActor m, MonadActorStage m ~ ActorStage a - , Actor a - , Eq (ActorKey a), Hashable (ActorKey a) - , H.HOccurs - (TVar (ActorRefMap a)) - (HList (Eval (Map Item_ (StageActors (ActorStage a))))) - ) - => ActorKey a -> ActorMessage a -> m Bool -send key msg = liftActor $ do - theater <- askTheater - liftIO $ sendIO theater key msg hSendTo :: ( Actor a , Eq (ActorKey a), Hashable (ActorKey a) ) - => (TVar (ActorRefMap a), Maybe (HashSet (ActorKey a), ActorMessage a)) + => (TVar (ActorRefOldMap a), Maybe (HashSet (ActorKey a), ActorMessage a)) -> IO () hSendTo (_ , Nothing) = pure () hSendTo (tvar, Just (recips, msg)) = do @@ -498,7 +1424,7 @@ data HSendTo = HSendTo instance ( Actor a , Eq (ActorKey a), Hashable (ActorKey a) - , i ~ (TVar (ActorRefMap a), Maybe (HashSet (ActorKey a), ActorMessage a)) + , i ~ (TVar (ActorRefOldMap a), Maybe (HashSet (ActorKey a), ActorMessage a)) ) => H.ApplyAB HSendTo i (IO ()) where applyAB _ a = hSendTo a @@ -513,7 +1439,7 @@ data Set_ :: Type -> Exp Type type instance Eval (Set_ a) = Maybe (HashSet (ActorKey a), ActorMessage a) data Pair__ :: Type -> Exp Type -type instance Eval (Pair__ a) = (Eval (Item_ a), Eval (Set_ a)) +type instance Eval (Pair__ a) = (Eval (ActorRefMapTVar_ a), Eval (Set_ a)) -- | Like 'sendMany', except it takes the theater as a parameter. sendManyIO @@ -522,15 +1448,15 @@ sendManyIO , Eval (Constraints (Eval (Map B_ (StageActors s)))) , H.HZipList - (Eval (Map Item_ (StageActors s))) + (Eval (Map ActorRefMapTVar_ (StageActors s))) (Eval (Map Set_ (StageActors s))) (Eval (Map Pair__ (StageActors s))) , H.SameLength' - (Eval (Map Item_ (StageActors s))) + (Eval (Map ActorRefMapTVar_ (StageActors s))) (Eval (Map Set_ (StageActors s))) , H.SameLength' (Eval (Map Set_ (StageActors s))) - (Eval (Map Item_ (StageActors s))) + (Eval (Map ActorRefMapTVar_ (StageActors s))) , H.SameLength' (Eval (Map Set_ (StageActors s))) (Eval (Map Pair__ (StageActors s))) @@ -574,15 +1500,15 @@ sendMany , Eval (Constraints (Eval (Map B_ (StageActors s)))) , H.HZipList - (Eval (Map Item_ (StageActors s))) + (Eval (Map ActorRefMapTVar_ (StageActors s))) (Eval (Map Set_ (StageActors s))) (Eval (Map Pair__ (StageActors s))) , H.SameLength' - (Eval (Map Item_ (StageActors s))) + (Eval (Map ActorRefMapTVar_ (StageActors s))) (Eval (Map Set_ (StageActors s))) , H.SameLength' (Eval (Map Set_ (StageActors s))) - (Eval (Map Item_ (StageActors s))) + (Eval (Map ActorRefMapTVar_ (StageActors s))) , H.SameLength' (Eval (Map Set_ (StageActors s))) (Eval (Map Pair__ (StageActors s))) @@ -610,66 +1536,87 @@ sendMany sendMany keys = liftActor $ do theater <- askTheater liftIO $ sendManyIO theater keys +-} --- | Same as 'spawn', except it takes the theater as a parameter. -spawnIO - :: forall a s. - ( ActorLaunch a, ActorStage a ~ s - , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) - , Message (ActorMessage a) - , Show (ActorReturn a) +{- - , H.HOccurs - (TVar (HashMap (ActorKey a) (ActorRef a))) - (HList (Eval (Map Item_ (StageActors s)))) - ) - => TheaterFor s - -> ActorKey a - -> IO (StageEnv s) - -> IO Bool -spawnIO theater@(TheaterFor hlist _) key mkEnv = do - let tvar = H.hOccurs hlist :: TVar (ActorRefMap a) - chan <- newChan - added <- atomically $ stateTVar tvar $ \ hm -> - let hm' = HM.alter (create $ ActorRef $ ActorRef' chan) key hm - in ( not (HM.member key hm) && HM.member key hm' - , hm' - ) - when added $ do - env <- mkEnv - launchActorThread chan theater key env - return added - where - create actor Nothing = Just actor - create _ j@(Just _) = j +-- A way to collect a Signature's params and return value into a convenient +-- type we call Signature' +-- +-- For example, given this signature: +-- +-- @ +-- type SaveTheWorld :: Signature +-- type SaveTheWorld = Int :-> String :-> Return Bool +-- @ +-- +-- We can do the following: +-- +-- @ +-- type SaveTheWorld' :: Signature' +-- type SaveTheWorld' = Pack SaveTheWorld +-- @ +-- +-- Which is equivalent to: +-- +-- @ +-- type SaveTheWorld' :: Signature' +-- type SaveTheWorld' = Signature' [Int, String] Bool +-- @ --- | Launch a new actor with the given ID and behavior. Return 'True' if the ID --- was unused and the actor has been launched. Return 'False' if the ID is --- already in use, thus a new actor hasn't been launched. -spawn - :: forall m a s. - ( MonadActor m, MonadActorStage m ~ s - , ActorLaunch a, ActorStage a ~ s - , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) - , Message (ActorMessage a) - , Show (ActorReturn a) +data Signature' = Signature' [Type] Type - , H.HOccurs - (TVar (HashMap (ActorKey a) (ActorRef a))) - (HList (Eval (Map Item_ (StageActors s)))) - ) - => ActorKey a - -> IO (StageEnv s) - -> m Bool -spawn key mkEnv = liftActor $ do - theater <- askTheater - liftIO $ spawnIO theater key mkEnv +--type PrependParam :: Type -> Signature' -> Signature' +type family PrependParam (t :: Type) (s :: Signature') = (s' :: Signature') | s' -> t s where + PrependParam t ('Signature' params ret) = 'Signature' (t ': params) ret -done :: Monad m => a -> m (a, ActFor s (), Next) -done msg = return (msg, return (), Proceed) +--type Pack :: Signature -> Signature' +type family Pack (s :: Signature) = (s' :: Signature') | s' -> s where + Pack ('Return t) = 'Signature' '[] t + Pack (t ':-> sig) = PrependParam t (Pack sig) -doneAnd :: Monad m => a -> ActFor s () -> m (a, ActFor s (), Next) -doneAnd msg act = return (msg, act, Proceed) +-- Getters for the Signature' type -stop :: Monad m => a -> m (a, ActFor s (), Next) -stop msg = return (msg, return (), Stop) +type SignatureParams' :: Signature' -> [Type] +type family SignatureParams' s where + SignatureParams' ('Signature' params _) = params + +type SignatureReturn' :: Signature' -> Type +type family SignatureReturn' s where + SignatureReturn' ('Signature' _ ret) = ret + +-- The actual message inserted into an actor's queue +-- +-- For example, given this signature: +-- +-- @ +-- type SaveTheWorld :: Signature +-- type SaveTheWorld = Int :-> String :-> Return Bool +-- @ +-- +-- We could do the following (a bit silly example, the functions @sendBool@ and +-- @sendString@ don't really exist, they're just for the sake of the example): +-- +-- @ +-- parcel :: Parcel (Pack SaveTheWorld) +-- parcel = Parcel +-- { +-- -- HList [Int, String] +-- parcelParams = 5 `H.HCons` "cool" `H.HCons` H.HNil +-- +-- -- Either SomeException Bool -> IO () +-- , parcelReturn = \case +-- Left e -> sendString $ displayException e +-- Right b -> +-- if b +-- then sendBool True +-- else sendBool False +-- } +-- @ + +data Parcel (s :: Signature') = Parcel + { parcelParams :: HList (SignatureParams' s) + , parcelReturn :: Either SomeException (SignatureReturn' s) -> IO () + } + +-} diff --git a/src/Control/Monad/Trans/Except/Local.hs b/src/Control/Monad/Trans/Except/Local.hs index 3d75406..3b5ba7c 100644 --- a/src/Control/Monad/Trans/Except/Local.hs +++ b/src/Control/Monad/Trans/Except/Local.hs @@ -18,7 +18,6 @@ module Control.Monad.Trans.Except.Local , verifyNothingE , nameExceptT , verifySingleE - , hoistMaybe ) where @@ -42,6 +41,3 @@ verifySingleE list none several = [] -> throwE none [x] -> pure x _ -> throwE several - -hoistMaybe :: Applicative m => Maybe b -> MaybeT m b -hoistMaybe = MaybeT . pure diff --git a/src/Darcs/Local/Repository.hs b/src/Darcs/Local/Repository.hs index 5c120a1..89a6804 100644 --- a/src/Darcs/Local/Repository.hs +++ b/src/Darcs/Local/Repository.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2022 by fr33domlover . + - Written in 2016, 2019, 2022, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -14,85 +14,19 @@ -} module Darcs.Local.Repository - ( writeDefaultsFile - , createRepo - , readPristineRoot + ( createRepo ) where -import Darcs.Util.Hash import Data.Bits import Data.Text (Text) -import System.Directory (createDirectory) -import System.Exit (ExitCode (..)) -import System.FilePath (()) -import System.IO (withBinaryFile, IOMode (ReadMode)) +import System.Directory +import System.Exit +import System.FilePath import System.Posix.Files -import System.Process (createProcess, proc, waitForProcess) +import System.Process import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.IO as TIO -writeDefaultsFile :: FilePath -> FilePath -> Text -> Text -> IO () -writeDefaultsFile path cmd authority repo = do - let file = path "_darcs" "prefs" "defaults" - TIO.writeFile file $ defaultsContent cmd authority repo - setFileMode file $ ownerReadMode .|. ownerWriteMode - where - defaultsContent :: FilePath -> Text -> Text -> Text - defaultsContent hook authority repo = - T.concat - [ "apply posthook " - , T.pack hook, " ", authority, " ", repo - ] - -{- -initialRepoTree :: FileName -> DirTree B.ByteString -initialRepoTree repo = - Dir repo - [ Dir "_darcs" - --[ File "format" - -- "hashed|no-working-dir\n\ - -- \darcs-2" - --, File "hashed_inventory" "" - --, File "index" ??? - , Dir "inventories" [] - , Dir "patches" [] - , Dir "prefs" [] - -- [ File "binaries" "" - -- , File "boring" "" - -- , File "motd" "" - -- ] - , Dir "pristine.hashed" [] - ] - ] --} - --- | initialize a new bare repository at a specific location. -createRepo - :: FilePath - -- ^ Parent directory which already exists - -> Text - -- ^ Repo keyhashid, i.e. new directory to create under the parent - -> FilePath - -- ^ Path of Vervis hook program - -> Text - -- ^ Instance HTTP authority - -> IO () -createRepo parent repo cmd authority = do - let path = parent T.unpack repo - createDirectory path - let settings = proc "darcs" ["init", "--no-working-dir", "--repodir", path] - (_, _, _, ph) <- createProcess settings - ec <- waitForProcess ph - case ec of - ExitSuccess -> writeDefaultsFile path cmd authority repo - ExitFailure n -> error $ "darcs init failed with exit code " ++ show n - -readPristineRoot :: FilePath -> IO (Maybe Int, Hash) -readPristineRoot darcsDir = do - let inventoryFile = darcsDir "hashed_inventory" - line <- withBinaryFile inventoryFile ReadMode B.hGetLine - let hashBS = B.drop 9 line - return (Nothing, decodeBase16 hashBS) diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index 5c46eaf..79682cb 100644 --- a/src/Data/Aeson/Local.hs +++ b/src/Data/Aeson/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2022 by fr33domlover . + - Written in 2019, 2022, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -60,25 +60,25 @@ fromEither :: Either a b -> Either' a b fromEither (Left x) = Left' x fromEither (Right y) = Right' y -(.:|) :: FromJSON a => Object -> Text -> Parser a +(.:|) :: FromJSON a => Object -> Key -> Parser a o .:| t = o .: t <|> o .: (frg <> t) where frg = "https://forgefed.org/ns#" -(.:|?) :: FromJSON a => Object -> Text -> Parser (Maybe a) +(.:|?) :: FromJSON a => Object -> Key -> Parser (Maybe a) o .:|? t = optional $ o .:| t -(.:+) :: (FromJSON a, FromJSON b) => Object -> Text -> Parser (Either a b) +(.:+) :: (FromJSON a, FromJSON b) => Object -> Key -> Parser (Either a b) o .:+ t = Left <$> o .: t <|> Right <$> o .: t (.:+?) :: (FromJSON a, FromJSON b) - => Object -> Text -> Parser (Maybe (Either a b)) + => Object -> Key -> Parser (Maybe (Either a b)) o .:+? t = optional $ o .:+ t -- | For JSON-LD properties that aren't functional, i.e. can have any number of -- values -(.:*) :: FromJSON a => Object -> Text -> Parser [a] +(.:*) :: FromJSON a => Object -> Key -> Parser [a] o .:* t = do maybeOneOrArray <- o .:+? t case maybeOneOrArray of @@ -88,44 +88,44 @@ o .:* t = do -- | For JSON-LD properties that aren't functional, i.e. can have any number of -- values -(.:*+) :: FromJSON a => Object -> Text -> Parser (NonEmpty a) +(.:*+) :: FromJSON a => Object -> Key -> Parser (NonEmpty a) o .:*+ t = do oneOrArray <- o .:+ t case oneOrArray of Left v -> return $ v :| [] - Right [] -> fail $ "No values for " ++ T.unpack t + Right [] -> fail $ "No values for " ++ show t Right (v:vs) -> return $ v :| vs infixr 8 .=? -(.=?) :: ToJSON v => Text -> Maybe v -> Series +(.=?) :: ToJSON v => Key -> Maybe v -> Series _ .=? Nothing = mempty k .=? (Just v) = k .= v infixr 8 .=% -(.=%) :: ToJSON v => Text -> [v] -> Series +(.=%) :: ToJSON v => Key -> [v] -> Series k .=% v = if null v then mempty else k .= v infixr 8 .=+ -(.=+) :: (ToJSON a, ToJSON b) => Text -> Either a b -> Series +(.=+) :: (ToJSON a, ToJSON b) => Key -> Either a b -> Series k .=+ Left x = k .= x k .=+ Right y = k .= y infixr 8 .=+? -(.=+?) :: (ToJSON a, ToJSON b) => Text -> Maybe (Either a b) -> Series +(.=+?) :: (ToJSON a, ToJSON b) => Key -> Maybe (Either a b) -> Series k .=+? Nothing = mempty k .=+? (Just v) = k .=+ v infixr 8 .=* -(.=*) :: ToJSON a => Text -> [a] -> Series +(.=*) :: ToJSON a => Key -> [a] -> Series _ .=* [] = mempty k .=* [v] = k .= v k .=* vs = k .= vs infixr 8 .=*+ -(.=*+) :: ToJSON a => Text -> NonEmpty a -> Series +(.=*+) :: ToJSON a => Key -> NonEmpty a -> Series k .=*+ (v :| []) = k .= v k .=*+ (v :| vs) = k .= (v:vs) diff --git a/src/Data/List/Local.hs b/src/Data/List/Local.hs index e0f8c52..0c4940a 100644 --- a/src/Data/List/Local.hs +++ b/src/Data/List/Local.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020 by fr33domlover . + - Written in 2016, 2018, 2019, 2020, 2024 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -23,6 +24,7 @@ module Data.List.Local , groupMapBy1 , lookupSorted , sortAlign + , spanJust ) where @@ -123,3 +125,12 @@ sortAlign xs ys = orderedAlign (prepare xs) (prepare ys) LT -> (u, This w) : orderedAlign us ys EQ -> (u, These w z) : orderedAlign us vs GT -> (v, That z) : orderedAlign xs vs + +spanJust :: (a -> Maybe b) -> [a] -> ([b], [a]) +spanJust _ [] = ([], []) +spanJust f (x:xs) = + case f x of + Nothing -> ([], x:xs) + Just y -> + let (us, vs) = spanJust f xs + in (y:us, vs) diff --git a/src/Data/ObjId.hs b/src/Data/ObjId.hs new file mode 100644 index 0000000..ab4a433 --- /dev/null +++ b/src/Data/ObjId.hs @@ -0,0 +1,76 @@ +{- This file is part of Vervis. + - + - Written in 2016, 2018, 2019, 2022, 2024 + - by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Data.ObjId + ( ObjId (..) + , parseObjId + , renderObjId + ) +where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader +import Data.Bits +import Data.Char +import Data.Either +import Data.Foldable +import Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe +import Data.Map (Map) +import Data.Set (Set) +import Data.Text (Text) +import Data.Time.Format +import Data.Traversable +import Data.Tree +import System.Directory +import System.FilePath +import System.Posix.Files +import System.Process.Typed +import Text.Email.Validate +import Text.Read (readMaybe) +import Text.XML.Light + +import qualified Data.Attoparsec.Text as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO + +import qualified Data.VersionControl as VC + +import Control.Monad.Trans.Except.Local + +data ObjId = ObjId { unObjId :: B.ByteString } deriving Eq + +parseObjId :: Text -> IO ObjId +parseObjId t = + case B16.decode $ TE.encodeUtf8 t of + Left e -> error $ "parseObjId: " ++ e + Right b -> pure $ ObjId b + +renderObjId :: ObjId -> Text +renderObjId (ObjId b) = + either (error . displayException) id $ TE.decodeUtf8' $ B16.encode b diff --git a/src/Database/Persist/Local.hs b/src/Database/Persist/Local.hs index ce74b2f..8a47b95 100644 --- a/src/Database/Persist/Local.hs +++ b/src/Database/Persist/Local.hs @@ -18,7 +18,6 @@ module Database.Persist.Local , valAndNew , getKeyBy , getValBy - , insertUnique_ , insertBy' , insertByEntity' , getE @@ -68,20 +67,12 @@ getValBy -> ReaderT backend m (Maybe record) getValBy u = fmap entityVal <$> getBy u -insertUnique_ - :: ( MonadIO m - , PersistRecordBackend record backend - , PersistUniqueWrite backend - ) - => record - -> ReaderT backend m () -insertUnique_ = void . insertUnique - insertBy' :: ( MonadIO m , PersistUniqueWrite backend , PersistRecordBackend record backend , AtLeastOneUniqueKey record + , SafeToInsert record ) => record -> ReaderT backend m (Either (Entity record) (Key record)) insertBy' val = do @@ -101,6 +92,7 @@ insertByEntity' , PersistUniqueWrite backend , PersistRecordBackend record backend , AtLeastOneUniqueKey record + , SafeToInsert record ) => record -> ReaderT backend m (Either (Entity record) (Entity record)) insertByEntity' val = second (flip Entity val) <$> insertBy' val diff --git a/src/Development/Darcs.hs b/src/Development/Darcs.hs new file mode 100644 index 0000000..a1bc0d6 --- /dev/null +++ b/src/Development/Darcs.hs @@ -0,0 +1,411 @@ +{- This file is part of Vervis. + - + - Written in 2016, 2018, 2019, 2022, 2024 + - by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Development.Darcs + ( DarcsT + , withDarcsRepo + , withDarcsRepoE + , darcs + , darcs' + , darcs_ + , darcsE + , darcsE_ + + , writeDefaultsFile + , createRepo + , isDarcsRepo + + , DirTree (..) + , darcsGetTree + , lookupTreeItem + , darcsGetFileContent + , darcsListTags + , darcsListTags' + , xml2patch + , darcsLog + , darcsLogLength + , darcsShowCommit + , darcsDiff + , darcsGetHead + ) +where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader +import Data.Bits +import Data.Char +import Data.Foldable +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe +import Data.Map (Map) +import Data.Set (Set) +import Data.Text (Text) +import Data.Time.Format +import Data.Traversable +import Data.Tree +import System.Directory +import System.FilePath +import System.Posix.Files +import System.Process.Typed +import Text.Email.Validate +import Text.Read (readMaybe) +import Text.XML.Light + +import qualified Data.Attoparsec.Text as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO + +import qualified Data.VersionControl as VC + +import Data.ObjId + +import Control.Monad.Trans.Except.Local + +writeDefaultsFile :: FilePath -> FilePath -> Text -> Text -> IO () +writeDefaultsFile path cmd authority repo = do + let file = path "_darcs" "prefs" "defaults" + TIO.writeFile file $ defaultsContent cmd authority repo + setFileMode file $ ownerReadMode .|. ownerWriteMode + where + defaultsContent :: FilePath -> Text -> Text -> Text + defaultsContent hook authority repo = + T.concat + [ "apply posthook " + , T.pack hook, " ", authority, " ", repo + ] + +-- | initialize a new bare repository at a specific location. +createRepo + :: FilePath + -- ^ Parent directory which already exists + -> Text + -- ^ Repo keyhashid, i.e. new directory to create under the parent + -> FilePath + -- ^ Path of Vervis hook program + -> Text + -- ^ Instance HTTP authority + -> IO () +createRepo parent repo cmd authority = do + let path = parent T.unpack repo + createDirectory path + runProcess_ $ setStdin nullStream $ proc "darcs" ["init", "--no-working-dir", "--repodir", path] + writeDefaultsFile path cmd authority repo + +isDarcsRepo :: FilePath -> IO Bool +isDarcsRepo path = do + items <- listDirectory path + case find (== "_darcs") items of + Nothing -> pure False + Just item -> doesDirectoryExist $ path item + +type DarcsT m a = ReaderT FilePath m a + +withDarcsRepo :: MonadIO m => FilePath -> DarcsT m a -> m a +withDarcsRepo path action = runReaderT action path + +type DarcsE m a = ExceptT Text (ReaderT FilePath m) a + +withDarcsRepoE :: MonadIO m => FilePath -> DarcsE m a -> ExceptT Text m a +withDarcsRepoE path action = ExceptT $ withDarcsRepo path $ runExceptT action + +darcs :: MonadIO m => String -> [String] -> DarcsT m Text +darcs = darcs' "--repodir" + +-- Same as 'darcs', except it alows to specify the name of the property used +-- for the repo path +darcs' :: MonadIO m => String -> String -> [String] -> DarcsT m Text +darcs' repoOption cmd args = do + repo <- ask + lb <- readProcessStdout_ $ setStdin nullStream $ proc "darcs" $ cmd : args ++ [repoOption, repo] + liftIO $ either throwIO return $ TE.decodeUtf8' $ BL.toStrict lb + +darcs_ :: MonadIO m => String -> [String] -> DarcsT m () +darcs_ cmd args = do + repo <- ask + runProcess_ $ setStdin nullStream $ proc "darcs" $ cmd : args ++ ["--repodir", repo] + +darcsE :: MonadIO m => String -> [String] -> DarcsE m Text +darcsE cmd args = do + repo <- lift ask + (code, lb) <- readProcessStdout $ setStdin nullStream $ proc "darcs" $ [cmd, "--repodir", repo] ++ args + case code of + ExitSuccess -> pure () + ExitFailure c -> throwE $ "darcsE " <> T.pack cmd <> " exited with code " <> T.pack (show c) + either (throwE . T.pack . displayException) return $ TE.decodeUtf8' $ BL.toStrict lb + +darcsE_ :: MonadIO m => String -> [String] -> DarcsE m () +darcsE_ cmd args = do + repo <- lift ask + code <- runProcess $ setStdin nullStream $ proc "darcs" $ [cmd, "--repodir", repo] ++ args + case code of + ExitSuccess -> pure () + ExitFailure c -> throwE $ "darcsE_ " <> T.pack cmd <> " exited with code " <> T.pack (show c) + +type FileName = String + +parseEntry :: Text -> IO (NonEmpty FileName) +parseEntry t = + case splitDirectories $ T.unpack t of + "." : (p : ieces) -> pure $ p :| ieces + _ -> error "parseEntry: Unexpected line format" + +parseSkeleton :: Text -> IO [Tree FileName] +parseSkeleton input = do + let lines = T.lines input + lines' <- + case lines of + [] -> error "parseSkeleton: No lines" + "." : ls -> pure ls + _ -> error "parseSkeleton: First line isn't \".\"" + entries <- traverse parseEntry lines' + either error pure $ buildTreeE entries + where + {- + reverseTree (Node label children) = Node label $ reverseForest children + reverseForest trees = map reverseTree $ reverse trees + -} + + partitionDirs :: [NonEmpty a] -> ([(a, NonEmpty a)], [(a, [(a, NonEmpty a)])]) + partitionDirs = foldr go ([], []) + where + go (x :| xs) (dir, dirs) = + case xs of + [] -> ([] , (x, dir) : dirs) + (y:ys) -> ((x, y :| ys) : dir, dirs) + + partitionDirsE :: (Eq a, Show a) => [NonEmpty a] -> Either String [(a, [NonEmpty a])] + partitionDirsE entries = + let (firsts, dirs) = partitionDirs entries + in if null firsts + then for dirs $ \ (dirname, children) -> + fmap (dirname,) $ for children $ \ (n, ns) -> + if (n == dirname) + then Right ns + else Left $ "Under " ++ show dirname ++ " found " ++ show (n, ns) + else Left $ "First item(s) don't have a parent dir: " ++ show firsts + + buildTreeE :: (Eq a, Show a) => [NonEmpty a] -> Either String [Tree a] + buildTreeE entries = do + dirs <- partitionDirsE entries + traverse makeTreeE dirs + where + makeTreeE :: (Eq a, Show a) => (a, [NonEmpty a]) -> Either String (Tree a) + makeTreeE (name, children) = do + dirs <- partitionDirsE children + trees <- traverse makeTreeE dirs + Right $ Node name trees + +data DirTree = DirTree + { _dtDirs :: [(FileName, DirTree)] + , _dtFiles :: [FileName] + } + deriving Show + +treeToDT :: [Tree FileName] -> DirTree +treeToDT trees = DirTree (map adaptTree trees) [] + where + adaptTree (Node name children) = (name, treeToDT children) + +parseFiles :: Text -> IO [NonEmpty FileName] +parseFiles input = do + let lines = T.lines input + traverse parseEntry lines + +insertFileE :: NonEmpty FileName -> DirTree -> Either String DirTree +insertFileE = go + where + go (x :| []) (DirTree dirs files) = Right $ DirTree dirs $ x : files + go (x :| (y : l)) (DirTree dirs files) = do + let (notEq, rest) = break ((== x) . fst) dirs + case rest of + [] -> Left $ show x ++ " not found in " ++ show dirs + ((n, tree) : rest') -> do + tree' <- go (y :| l) tree + let dirs' = notEq ++ (n, tree') : rest' + Right $ DirTree dirs' files + +darcsGetTree :: MonadIO m => Text -> DarcsT m DirTree +darcsGetTree hash = do + tree <- + darcs "show" ["files", "--no-pending", "--hash", T.unpack hash, "--no-files"] >>= + fmap treeToDT . liftIO . parseSkeleton + files <- + darcs "show" ["files", "--no-pending", "--hash", T.unpack hash, "--no-directories"] >>= + liftIO . parseFiles + either error pure $ foldrM insertFileE tree files + +lookupTreeItem :: [FileName] -> DirTree -> Maybe (Either () DirTree) +lookupTreeItem [] tree = Just $ Right tree +lookupTreeItem (n:ns) tree = go (n :| ns) tree + where + go (x :| []) (DirTree dirs files) = + case lookup x dirs of + Just tree -> Just $ Right tree + Nothing -> + if x `elem` files + then Just $ Left () + else Nothing + go (x :| (y : l)) (DirTree dirs _) = do + tree <- lookup x dirs + go (y :| l) tree + +darcsGetFileContent :: MonadIO m => Text -> FilePath -> DarcsT m Text +darcsGetFileContent hash path = + darcs "show" ["contents", "--hash", T.unpack hash, path] + +parseTags :: Text -> IO [Text] +parseTags t = traverse grab $ map T.words $ T.lines t + where + grab [tag] = pure tag + grab _ = error "Unexpected tag line" + +darcsListTags :: MonadIO m => DarcsT m (Set Text) +darcsListTags = do + t <- darcs' "--repo" "show" ["tags"] + ts <- liftIO $ parseTags t + return $ S.fromList ts + +darcsListTags' :: MonadIO m => DarcsT m (Map Text ObjId) +darcsListTags' = do + t <- darcs "log" ["--xml-output", "--tags=."] + case parseCommits t of + Nothing -> error "parseCommits failed" + Just cs -> liftIO $ fmap M.fromList $ for cs $ \ c -> do + oid <- parseObjId $ VC.commitHash c + name <- + case T.stripPrefix "TAG " $ VC.commitTitle c of + Nothing -> error "No TAG prefix" + Just n -> pure n + return (name, oid) + +xml2patch :: Monad m => Element -> ExceptT Text m VC.Commit +xml2patch elem = do + unless (elName elem == QName "patch" Nothing Nothing) $ + throwE $ + "Expected , found: " <> T.pack (show $ elName elem) + (name, email) <- do + t <- T.pack <$> findAttrE "author" elem + parseOnlyE authorP t "author" + date <- do + s <- findAttrE "date" elem + case parseTimeM False defaultTimeLocale "%Y%m%d%H%M%S" s of + Nothing -> throwE $ "Date parsing failed: " <> T.pack s + Just t -> return t + hash <- do + t <- T.pack <$> findAttrE "hash" elem + unless (T.length t == 40) $ + throwE $ "Expected a hash string of length 40, got: " <> t + return t + + inverted <- do + s <- findAttrE "inverted" elem + readMaybeE s $ "Unrecognized inverted value: " <> T.pack s + when inverted $ throwE $ "Found inverted patch " <> hash + + title <- T.pack . strContent <$> findChildE "name" elem + description <- do + t <- T.pack . strContent <$> findChildE "comment" elem + parseOnlyE commentP t "comment" + + return VC.Commit + { VC.commitWritten = (VC.Author name email, date) + , VC.commitCommitted = Nothing + , VC.commitHash = hash + , VC.commitTitle = title + , VC.commitDescription = description + } + where + readMaybeE s e = fromMaybeE (readMaybe s) e + findAttrE q e = + let ms = findAttr (QName q Nothing Nothing) e + in fromMaybeE ms $ "Couldn't find attr \"" <> T.pack q <> "\"" + findChildE q e = + case findChildren (QName q Nothing Nothing) e of + [] -> throwE $ "No children named " <> T.pack q + [c] -> return c + _ -> throwE $ "Multiple children named " <> T.pack q + authorP = (,) + <$> (T.stripEnd <$> A.takeWhile1 (/= '<')) + <* A.skip (== '<') + <*> (A.takeWhile1 (/= '>') >>= emailP) + <* A.skip (== '>') + where + emailP + = maybe (fail "Invalid email") pure + . emailAddress + . TE.encodeUtf8 + commentP + = A.string "Ignore-this: " + *> A.takeWhile1 isHexDigit + *> (fromMaybe T.empty <$> + optional (A.endOfLine *> A.endOfLine *> A.takeText) + ) + parseOnlyE p t n = + case A.parseOnly (p <* A.endOfInput) t of + Left e -> + throwE $ T.concat ["Parsing ", n, " failed: ", T.pack e] + Right a -> return a + +parseCommits :: Text -> Maybe [VC.Commit] +parseCommits input = do + element <- parseXMLDoc input + either (const Nothing) Just $ runExcept $ + traverse xml2patch $ elChildren element + +darcsLog :: MonadIO m => Maybe Int -> Maybe Int -> DarcsT m [VC.Commit] +darcsLog maybeLimit maybeOffset = do + let offset = fromMaybe 0 maybeOffset + limit = fromMaybe 1000000000 maybeLimit + from = offset + 1 + to = offset + limit + t <- darcs "log" ["--xml-output", "--index", show from ++ "-" ++ show to] + case parseCommits t of + Just cs -> pure cs + Nothing -> error "parseCommits failed" + +darcsLogLength :: MonadIO m => DarcsT m Int +darcsLogLength = pure . read . T.unpack =<< darcs "log" ["--count"] + +darcsShowCommit :: MonadIO m => ObjId -> DarcsT m (VC.Commit) +darcsShowCommit oid = do + t <- darcs "log" ["--xml-output", "--hash", T.unpack $ renderObjId oid] + case parseCommits t of + Just [c] -> pure c + Just _ -> error "darcs expected to return exactly one patch" + Nothing -> error "parseCommits failed" + +darcsDiff :: MonadIO m => ObjId -> DarcsT m Text +darcsDiff patchOid = + let patchHash = renderObjId patchOid + in darcs "diff" ["--hash", T.unpack patchHash] + +darcsGetHead :: MonadIO m => DarcsT m Text +darcsGetHead = do + cs <- darcsLog (Just 1) Nothing + case cs of + [c] -> pure $ VC.commitHash c + _ -> error "darcsGetHead: Expected exactly one patch" diff --git a/src/Data/Git/Local.hs b/src/Development/Git.hs similarity index 96% rename from src/Data/Git/Local.hs rename to src/Development/Git.hs index 2b8baf8..4a04827 100644 --- a/src/Data/Git/Local.hs +++ b/src/Development/Git.hs @@ -14,7 +14,7 @@ - . -} -module Data.Git.Local +module Development.Git ( GitT , withGitRepo , withGitRepoE @@ -27,10 +27,6 @@ module Data.Git.Local , createRepo , isGitRepo - , ObjId (..) - , parseObjId - , renderObjId - , TreeEntryType (..) , TreeEntry (..) , gitListDir @@ -86,6 +82,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.IO as TIO +import Data.ObjId + import qualified Data.VersionControl as VC hookContent :: FilePath -> Text -> Text -> Text @@ -200,18 +198,6 @@ gitE_ cmd args = do ExitSuccess -> pure () ExitFailure c -> throwE $ "gitE_ " <> T.pack cmd <> " exited with code " <> T.pack (show c) -data ObjId = ObjId { unObjId :: B.ByteString } deriving Eq - -parseObjId :: Text -> IO ObjId -parseObjId t = - case B16.decode $ TE.encodeUtf8 t of - Left e -> error $ "parseObjId: " ++ e - Right b -> pure $ ObjId b - -renderObjId :: ObjId -> Text -renderObjId (ObjId b) = - either (error . displayException) id $ TE.decodeUtf8' $ B16.encode b - data TreeEntryType = TETFile Text | TETDir data TreeEntry = TreeEntry diff --git a/src/Network/Git/Get.hs b/src/Network/Git/Get.hs index 79eeffc..025971c 100644 --- a/src/Network/Git/Get.hs +++ b/src/Network/Git/Get.hs @@ -36,10 +36,11 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as BC +import Data.ObjId +import Development.Git import Network.Git.Types import Data.Binary.Get.Local -import Data.Git.Local getFlushPkt :: Get () getFlushPkt = requireByteString "0000" diff --git a/src/Network/Git/Put.hs b/src/Network/Git/Put.hs index ba49303..a12a1e0 100644 --- a/src/Network/Git/Put.hs +++ b/src/Network/Git/Put.hs @@ -46,10 +46,11 @@ import Data.Monoid ((<>)) import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as B16 +import Data.ObjId +import Development.Git import Network.Git.Types import Data.Binary.Put.Local -import Data.Git.Local zeroObjId :: ObjId zeroObjId = ObjId $ B.replicate 20 0 diff --git a/src/Network/Git/Transport/HTTP/Fetch/RefDiscovery.hs b/src/Network/Git/Transport/HTTP/Fetch/RefDiscovery.hs index 4301170..39855b2 100644 --- a/src/Network/Git/Transport/HTTP/Fetch/RefDiscovery.hs +++ b/src/Network/Git/Transport/HTTP/Fetch/RefDiscovery.hs @@ -35,20 +35,19 @@ import Data.Bifunctor import Data.Binary.Put import Data.ByteString (ByteString) import Data.Foldable -import Data.Monoid ((<>)) -import Data.Version (showVersion) import qualified Data.ByteString as B (length) -import qualified Data.ByteString.Char8 as BC (pack) import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Data.Map as M import qualified Data.Text.Encoding as TE -import Data.Binary.Put.Local -import Data.Git.Local +import Data.ObjId +import Development.Git import Network.Git.Put import Network.Git.Types +import Data.Binary.Put.Local + ------------------------------------------------------------------------------- -- Types ------------------------------------------------------------------------------- diff --git a/src/Network/Git/Transport/HTTP/Fetch/UploadRequest.hs b/src/Network/Git/Transport/HTTP/Fetch/UploadRequest.hs index 184fcd3..5d520b5 100644 --- a/src/Network/Git/Transport/HTTP/Fetch/UploadRequest.hs +++ b/src/Network/Git/Transport/HTTP/Fetch/UploadRequest.hs @@ -29,11 +29,12 @@ import Data.Binary.Get import qualified Data.ByteString.Char8 as BC (unpack) +import Data.ObjId +import Development.Git import Network.Git.Get import Network.Git.Types import Data.Binary.Get.Local -import Data.Git.Local ------------------------------------------------------------------------------- -- Types diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index dfc5bed..4b09f15 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -47,15 +47,17 @@ import Data.Bitraversable import Data.Foldable import Data.Functor import Data.Functor.Identity +import Data.HList (HList (..)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe +import Data.Proxy import Data.Text (Text) import Data.These import Data.Time.Clock import Data.Traversable import Database.Persist hiding (deleteBy) import Database.Persist.Sql hiding (deleteBy) -import Network.HTTP.Client +import Network.HTTP.Client hiding (Proxy) import System.Directory import System.Exit import System.FilePath @@ -72,7 +74,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL -import Control.Concurrent.Actor hiding (Actor) +import Control.Concurrent.Actor hiding (Actor, Handler) import Database.Persist.JSON import Development.PatchMediaType import Network.FedURI @@ -91,9 +93,9 @@ import Control.Monad.Trans.Except.Local import Data.Either.Local import Database.Persist.Local -import qualified Data.Git.Local as G (createRepo) +import qualified Development.Git as G (createRepo) import qualified Data.Text.UTF8.Local as TU -import qualified Darcs.Local.Repository as D (createRepo) +import qualified Development.Darcs as D (createRepo) import Vervis.ActivityPub import Vervis.Actor hiding (hashLocalActor) @@ -146,13 +148,12 @@ handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do theater <- asksSite appTheater let maybeCap' = first (\ (byKey, _, i) -> (byKey, i)) <$> maybeCap msg = ClientMsg maybeCap' localRecips remoteRecips fwdHosts action - maybeResult <- - liftIO $ callIO theater personID (PersonMsgClient msg) - itemText <- + maybeResult <- liftIO $ callIO' @"client" theater Proxy personID $ msg `HCons` HNil + outboxItemID <- case maybeResult of Nothing -> error "Person not found in theater" Just (Left e) -> throwE e - Just (Right t) -> return t + Just (Right k) -> return k logDebug $ T.concat [ "handleViaActor: Submitting activity to ", T.pack $ show personID --, "\n localRecips=", T.pack $ show localRecips @@ -160,9 +161,7 @@ handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do , "\n fwdHosts=", T.pack $ show fwdHosts --, "\n action=", T.pack $ show action ] - case readMaybe $ T.unpack itemText of - Nothing -> error "read itemText failed" - Just outboxItemID -> return outboxItemID + return outboxItemID verifyResourceAddressed :: (MonadSite m, YesodHashids (SiteEnv m)) diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 83ff5c6..ce398de 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2021, 2022, 2023 + - Written in 2019, 2020, 2021, 2022, 2023, 2024 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -84,7 +84,7 @@ import qualified Database.Esqueleto as E import Yesod.HttpSignature -import Control.Concurrent.Actor +import Control.Concurrent.Actor hiding (Handler) import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index 4292255..d671c1e 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -79,7 +79,6 @@ module Vervis.Actor , ClientMsg (..) -- * Behavior utility types - , VerseExt , StageEnv (..) , Staje , Act @@ -91,10 +90,10 @@ module Vervis.Actor -- * Behavior utilities , withDB , withDBExcept - , behave - , VervisActor (..) - , VervisActorLaunch (..) - , ActorMessage (..) + , adaptHandlerResult + --, VervisActor (..) + --, VervisActorLaunch (..) + --, ActorMessage (..) , launchActorIO , launchActor @@ -129,6 +128,7 @@ import Data.Time.Clock import Data.Traversable import Data.Typeable import Database.Persist.Sql +import Fcf import GHC.Generics import Network.HTTP.Client import UnliftIO.Exception @@ -484,71 +484,62 @@ data ClientMsg = ClientMsg , cmAction :: AP.Action URIMode } -summarizeVerse (Verse (Left (actor, _, itemID)) body) = - let typ = AP.activityType $ AP.activitySpecific $ actbActivity body - in T.concat [typ, " ", T.pack $ show actor, " ", T.pack $ show itemID] -summarizeVerse (Verse (Right (author, luAct, _)) body) = - let ObjURI h _ = remoteAuthorURI author - typ = AP.activityType $ AP.activitySpecific $ actbActivity body - in T.concat [typ, " ", renderObjURI $ ObjURI h luAct] - -referVerse (Verse (Left (actor, _, itemID)) _body) = - T.concat [T.pack $ show actor, " ", T.pack $ show itemID] -referVerse (Verse (Right (author, luAct, _)) _body) = - let ObjURI h _ = remoteAuthorURI author - in renderObjURI $ ObjURI h luAct - -type VerseExt = Either Verse ClientMsg - data Staje +type Ret :: Signature +type Ret = Return (Either Text Text) + instance Actor Person where type ActorStage Person = Staje type ActorKey Person = PersonId - type ActorReturn Person = Either Text Text - data ActorMessage Person - = PersonMsgVerse Verse - | PersonMsgClient ClientMsg - | PersonMsgInit + type ActorInterface Person = + [ "verse" ::: Verse :-> Ret + , "client" ::: ClientMsg :-> Return (Either Text OutboxItemId) + , "init" ::: Ret + ] instance Actor Deck where type ActorStage Deck = Staje type ActorKey Deck = DeckId - type ActorReturn Deck = Either Text Text - data ActorMessage Deck - = DeckMsgVerse Verse - | DeckMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) + type ActorInterface Deck = + [ "verse" ::: Verse :-> Ret + , "init" ::: (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) :-> Ret + ] instance Actor Loom where type ActorStage Loom = Staje type ActorKey Loom = LoomId - type ActorReturn Loom = Either Text Text - data ActorMessage Loom = MsgL Verse + type ActorInterface Loom = + '[ "verse" ::: Verse :-> Ret + ] instance Actor Repo where type ActorStage Repo = Staje type ActorKey Repo = RepoId - type ActorReturn Repo = Either Text Text - data ActorMessage Repo = MsgR (Either Verse (IO ())) + type ActorInterface Repo = + [ "verse" ::: Verse :-> Ret + , "wait-during-push" ::: IO () :-> Ret + ] instance Actor Project where type ActorStage Project = Staje type ActorKey Project = ProjectId - type ActorReturn Project = Either Text Text - data ActorMessage Project - = ProjectMsgVerse Verse - | ProjectMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) + type ActorInterface Project = + [ "verse" ::: Verse :-> Ret + , "init" ::: (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) :-> Ret + ] instance Actor Group where type ActorStage Group = Staje type ActorKey Group = GroupId - type ActorReturn Group = Either Text Text - data ActorMessage Group - = TeamMsgVerse Verse - | TeamMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) + type ActorInterface Group = + [ "verse" ::: Verse :-> Ret + , "init" ::: (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) :-> Ret + ] instance Actor Factory where type ActorStage Factory = Staje type ActorKey Factory = FactoryId - type ActorReturn Factory = Either Text Text - data ActorMessage Factory - = FactoryMsgVerse Verse - | FactoryMsgVerified PersonId + type ActorInterface Factory = + [ "verse" ::: Verse :-> Ret + , "verified" ::: PersonId :-> Ret + ] +{- instance VervisActor Person where actorVerse = PersonMsgVerse toVerse (PersonMsgVerse v) = Just v @@ -578,6 +569,7 @@ instance VervisActor Factory where actorVerse = FactoryMsgVerse toVerse (FactoryMsgVerse v) = Just v toVerse _ = Nothing +-} instance Stage Staje where data StageEnv Staje = forall y. (Typeable y, Yesod y) => Env @@ -606,42 +598,6 @@ instance Stage Staje where deriving Typeable type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo, Factory] -instance Message (ActorMessage Person) where - summarize (PersonMsgVerse verse) = summarizeVerse verse - summarize (PersonMsgClient _) = "PersonMsgClient" - summarize PersonMsgInit = "PersonMsgInit" - refer (PersonMsgVerse verse) = referVerse verse - refer (PersonMsgClient _) = "PersonMsgClient" - refer PersonMsgInit = "PersonMsgInit" -instance Message (ActorMessage Deck) where - summarize (DeckMsgVerse verse) = summarizeVerse verse - summarize (DeckMsgInit _) = "DeckMsgInit" - refer (DeckMsgVerse verse) = referVerse verse - refer (DeckMsgInit _) = "DeckMsgInit" -instance Message (ActorMessage Loom) where - summarize (MsgL verse) = summarizeVerse verse - refer (MsgL verse) = referVerse verse -instance Message (ActorMessage Repo) where - summarize (MsgR (Left verse)) = summarizeVerse verse - summarize (MsgR (Right _)) = "WaitPushCompletion" - refer (MsgR (Left verse)) = referVerse verse - refer (MsgR (Right _)) = "WaitPushCompletion" -instance Message (ActorMessage Project) where - summarize (ProjectMsgVerse verse) = summarizeVerse verse - summarize (ProjectMsgInit _) = "ProjectMsgInit" - refer (ProjectMsgVerse verse) = referVerse verse - refer (ProjectMsgInit _) = "ProjectMsgInit" -instance Message (ActorMessage Group) where - summarize (TeamMsgVerse verse) = summarizeVerse verse - summarize (TeamMsgInit _) = "TeamMsgInit" - refer (TeamMsgVerse verse) = referVerse verse - refer (TeamMsgInit _) = "TeamMsgInit" -instance Message (ActorMessage Factory) where - summarize (FactoryMsgVerse verse) = summarizeVerse verse - summarize (FactoryMsgVerified _) = "FactoryMsgVerified" - refer (FactoryMsgVerse verse) = referVerse verse - refer (FactoryMsgVerified _) = "FactoryMsgVerified" - type YesodRender y = Route y -> [(Text, Text)] -> Text instance StageWeb Staje where @@ -686,16 +642,16 @@ withDBExcept action = do where abort = throwIO . FedError -behave - :: (UTCTime -> ActorKey a -> ActorMessage a -> ExceptT Text Act (Text, Act (), Next)) - -> (ActorKey a -> ActorMessage a -> Act (Either Text Text, Act (), Next)) -behave handler key msg = do - now <- liftIO getCurrentTime - result <- runExceptT $ handler now key msg +adaptHandlerResult + :: ExceptT Text Act (a, Act (), Next) + -> Act (Either Text a, Act (), Next) +adaptHandlerResult handler = do + result <- runExceptT handler case result of Left e -> done $ Left e - Right (t, after, next) -> return (Right t, after, next) + Right (r, after, next) -> return (Right r, after, next) +{- class VervisActor a where actorVerse :: Verse -> ActorMessage a toVerse :: ActorMessage a -> Maybe Verse @@ -705,12 +661,11 @@ class VervisActor a => VervisActorLaunch a where instance (Actor a, VervisActorLaunch a, ActorReturn a ~ Either Text Text, ActorStage a ~ Staje) => ActorLaunch a where actorBehavior = behave actorBehavior' +-} launchActorIO :: ( ActorLaunch a, ActorStage a ~ Staje , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) - , Message (ActorMessage a) - , Show (ActorReturn a) , H.HEq (TVar (HashMap (ActorKey a) (ActorRef a))) (TVar (HashMap PersonId (ActorRef Person))) @@ -736,6 +691,34 @@ launchActorIO TVar (HashMap LoomId (ActorRef Loom)), TVar (HashMap RepoId (ActorRef Repo)), TVar (HashMap FactoryId (ActorRef Factory))] + + , ActorStage a ~ s + , ActorInterface a ~ ms + , Eval (Map (AdaptedHandler s) ms) + ~ + Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + , H.SameLength' + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + (Eval (Map (Handler_ a) ms)) + , H.SameLength' + (Eval (Map (Handler_ a) ms)) + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms))) + , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text) + , H.HMapAux + H.HList + (HAdaptHandler a) + (Eval (Map (Handler_ a) ms)) + (Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + ) ) => Theater -> StageEnv Staje @@ -746,8 +729,6 @@ launchActorIO theater env key = spawnIO theater key (pure env) launchActor :: ( ActorLaunch a, ActorStage a ~ Staje , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) - , Message (ActorMessage a) - , Show (ActorReturn a) , H.HEq (TVar (HashMap (ActorKey a) (ActorRef a))) (TVar (HashMap PersonId (ActorRef Person))) @@ -773,6 +754,34 @@ launchActor TVar (HashMap LoomId (ActorRef Loom)), TVar (HashMap RepoId (ActorRef Repo)), TVar (HashMap FactoryId (ActorRef Factory))] + + , ActorStage a ~ s + , ActorInterface a ~ ms + , Eval (Map (AdaptedHandler s) ms) + ~ + Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + , H.SameLength' + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + (Eval (Map (Handler_ a) ms)) + , H.SameLength' + (Eval (Map (Handler_ a) ms)) + (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms))) + , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text) + , H.HMapAux + H.HList + (HAdaptHandler a) + (Eval (Map (Handler_ a) ms)) + (Eval + (Map + (Func (AdaptedAction s, Text)) + (Eval (Map Parcel_ ms)) + ) + ) ) => ActorKey a -> Act Bool @@ -947,6 +956,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do -- Insert activity to message queues of all local live actors who are -- recipients, i.e. either directly addressed or listed in a local stage -- addressed + -- + -- Since 'sendMany' is temporarily unavailable, we just use plain send let liveRecips = let s = HS.fromList $ localFollowers ++ localActorsForSelf in case maidAuthor of @@ -957,6 +968,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do (liveRecipsP, liveRecipsJ, liveRecipsG, liveRecipsD, liveRecipsL, liveRecipsR, liveRecipsF) = partitionByActor liveRecips verse = Verse authorAndId' body + {- sendMany $ (Just (liveRecipsP, actorVerse verse)) `H.HCons` (Just (liveRecipsJ, actorVerse verse)) `H.HCons` @@ -965,6 +977,14 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do (Just (liveRecipsL, actorVerse verse)) `H.HCons` (Just (liveRecipsR, actorVerse verse)) `H.HCons` (Just (liveRecipsF, actorVerse verse)) `H.HCons` H.HNil + -} + for_ liveRecipsP $ \ k -> void $ send @"verse" k verse + for_ liveRecipsJ $ \ k -> void $ send @"verse" k verse + for_ liveRecipsG $ \ k -> void $ send @"verse" k verse + for_ liveRecipsD $ \ k -> void $ send @"verse" k verse + for_ liveRecipsL $ \ k -> void $ send @"verse" k verse + for_ liveRecipsR $ \ k -> void $ send @"verse" k verse + for_ liveRecipsF $ \ k -> void $ send @"verse" k verse -- Return remote followers, to whom we need to deliver via HTTP return remoteFollowers diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index ddabb37..cea1492 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -20,7 +20,7 @@ module Vervis.Actor.Deck where import Control.Applicative -import Control.Exception.Base +import Control.Exception.Base hiding (handle) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack @@ -32,6 +32,7 @@ import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) import Data.Foldable +import Data.HList (HList (..)) import Data.Maybe import Data.Text (Text) import Data.Time.Clock @@ -785,8 +786,9 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do -- Main behavior function ------------------------------------------------------------------------------ -deckBehavior :: UTCTime -> DeckId -> ActorMessage Deck -> ActE (Text, Act (), Next) -deckBehavior now deckID (DeckMsgVerse verse@(Verse _authorIdMsig body)) = +deckVerse :: DeckId -> Verse -> ActE (Text, Act (), Next) +deckVerse deckID verse@(Verse _authorIdMsig body) = do + now <- liftIO getCurrentTime case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> deckAccept now deckID verse accept AP.AddActivity add -> deckAdd now deckID verse add @@ -801,14 +803,21 @@ deckBehavior now deckID (DeckMsgVerse verse@(Verse _authorIdMsig body)) = AP.RevokeActivity revoke -> deckRevoke now deckID verse revoke AP.UndoActivity undo -> deckUndo now deckID verse undo _ -> throwE "Unsupported activity type for Deck" -deckBehavior now deckID (DeckMsgInit creator) = - let grabResource = fmap komponentResource . getJust . deckKomponent - in topicInit grabResource LocalResourceDeck now deckID creator -instance VervisActorLaunch Deck where - actorBehavior' now deckID ve = do - errboxID <- lift $ withDB $ do - resourceID <- deckResource <$> getJust deckID - Resource actorID <- getJust resourceID - actorErrbox <$> getJust actorID - adaptErrbox errboxID False deckBehavior now deckID ve +instance ActorLaunch Deck where + actorBehavior _ = + (handleMethod @"verse" := \ deckID verse -> adaptHandlerResult $ do + errboxID <- lift $ withDB $ do + resourceID <- deckResource <$> getJust deckID + Resource actorID <- getJust resourceID + actorErrbox <$> getJust actorID + adaptErrbox errboxID False (deckVerse deckID) verse + ) + `HCons` + (handleMethod @"init" := \ deckID creator -> adaptHandlerResult $ do + now <- liftIO getCurrentTime + let grabResource = fmap komponentResource . getJust . deckKomponent + topicInit grabResource LocalResourceDeck now deckID creator + ) + `HCons` + HNil diff --git a/src/Vervis/Actor/Factory.hs b/src/Vervis/Actor/Factory.hs index 404cf34..73980cf 100644 --- a/src/Vervis/Actor/Factory.hs +++ b/src/Vervis/Actor/Factory.hs @@ -19,7 +19,7 @@ module Vervis.Actor.Factory where import Control.Applicative -import Control.Exception.Base +import Control.Exception.Base hiding (handle) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack @@ -34,6 +34,7 @@ import Data.Bitraversable import Data.ByteString (ByteString) import Data.Either import Data.Foldable +import Data.HList (HList (..)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text (Text) @@ -1060,7 +1061,7 @@ factoryCreateNew new now factoryMeID (Verse authorIdMsig body) detail = do return ( LocalResourceDeck did , launchActor did - , send did $ DeckMsgInit authorId + , send @"init" did authorId ) NAProject -> do jid <- insert Project @@ -1070,7 +1071,7 @@ factoryCreateNew new now factoryMeID (Verse authorIdMsig body) detail = do return ( LocalResourceProject jid , launchActor jid - , send jid $ ProjectMsgInit authorId + , send @"init" jid authorId ) NATeam -> do gid <- insert Group @@ -1080,7 +1081,7 @@ factoryCreateNew new now factoryMeID (Verse authorIdMsig body) detail = do return ( LocalResourceGroup gid , launchActor gid - , send gid $ TeamMsgInit authorId + , send @"init" gid authorId ) return (lr, launch, sendInit, rid) @@ -2633,8 +2634,9 @@ factoryRevoke now factoryID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus return (action, recipientSet, remoteActors, fwdHosts) -factoryBehavior :: UTCTime -> FactoryId -> ActorMessage Factory -> ActE (Text, Act (), Next) -factoryBehavior now factoryID (FactoryMsgVerse verse@(Verse _authorIdMsig body)) = +factoryVerse :: FactoryId -> Verse -> ActE (Text, Act (), Next) +factoryVerse factoryID verse@(Verse _authorIdMsig body) = do + now <- liftIO getCurrentTime case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> factoryAccept now factoryID verse accept AP.AddActivity add -> factoryAdd now factoryID verse add @@ -2647,13 +2649,20 @@ factoryBehavior now factoryID (FactoryMsgVerse verse@(Verse _authorIdMsig body)) AP.RemoveActivity remove -> factoryRemove now factoryID verse remove AP.RevokeActivity revoke -> factoryRevoke now factoryID verse revoke _ -> throwE "Unsupported activity type for Factory" -factoryBehavior now factoryID (FactoryMsgVerified personID) = - factoryCheckPerson now factoryID personID -instance VervisActorLaunch Factory where - actorBehavior' now factoryID ve = do - errboxID <- lift $ withDB $ do - resourceID <- factoryResource <$> getJust factoryID - Resource actorID <- getJust resourceID - actorErrbox <$> getJust actorID - adaptErrbox errboxID False factoryBehavior now factoryID ve +instance ActorLaunch Factory where + actorBehavior _ = + (handleMethod @"verse" := \ factoryID verse -> adaptHandlerResult $ do + errboxID <- lift $ withDB $ do + resourceID <- factoryResource <$> getJust factoryID + Resource actorID <- getJust resourceID + actorErrbox <$> getJust actorID + adaptErrbox errboxID False (factoryVerse factoryID) verse + ) + `HCons` + (handleMethod @"verified" := \ factoryID personID -> adaptHandlerResult $ do + now <- liftIO getCurrentTime + factoryCheckPerson now factoryID personID + ) + `HCons` + HNil diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index e671e27..b10b187 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -19,7 +19,7 @@ module Vervis.Actor.Group where import Control.Applicative -import Control.Exception.Base +import Control.Exception.Base hiding (handle) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack @@ -34,6 +34,7 @@ import Data.Bitraversable import Data.ByteString (ByteString) import Data.Either import Data.Foldable +import Data.HList (HList (..)) import Data.Maybe import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) @@ -5902,8 +5903,9 @@ groupUndo now recipGroupID (Verse authorIdMsig body) (AP.Undo uObject) = do return (action, recipientSet, remoteActors, fwdHosts) -groupBehavior :: UTCTime -> GroupId -> ActorMessage Group -> ActE (Text, Act (), Next) -groupBehavior now groupID (TeamMsgVerse verse@(Verse _authorIdMsig body)) = +groupVerse :: GroupId -> Verse -> ActE (Text, Act (), Next) +groupVerse groupID verse@(Verse _authorIdMsig body) = do + now <- liftIO getCurrentTime case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> groupAccept now groupID verse accept AP.AddActivity add -> groupAdd now groupID verse add @@ -5916,14 +5918,21 @@ groupBehavior now groupID (TeamMsgVerse verse@(Verse _authorIdMsig body)) = AP.RevokeActivity revoke -> groupRevoke now groupID verse revoke AP.UndoActivity undo -> groupUndo now groupID verse undo _ -> throwE "Unsupported activity type for Group" -groupBehavior now groupID (TeamMsgInit creator) = - let grabResource = pure . groupResource - in topicInit grabResource LocalResourceGroup now groupID creator -instance VervisActorLaunch Group where - actorBehavior' now groupID ve = do - errboxID <- lift $ withDB $ do - resourceID <- groupResource <$> getJust groupID - Resource actorID <- getJust resourceID - actorErrbox <$> getJust actorID - adaptErrbox errboxID False groupBehavior now groupID ve +instance ActorLaunch Group where + actorBehavior _ = + (handleMethod @"verse" := \ groupID verse -> adaptHandlerResult $ do + errboxID <- lift $ withDB $ do + resourceID <- groupResource <$> getJust groupID + Resource actorID <- getJust resourceID + actorErrbox <$> getJust actorID + adaptErrbox errboxID False (groupVerse groupID) verse + ) + `HCons` + (handleMethod @"init" := \ groupID creator -> adaptHandlerResult $ do + now <- liftIO getCurrentTime + let grabResource = pure . groupResource + topicInit grabResource LocalResourceGroup now groupID creator + ) + `HCons` + HNil diff --git a/src/Vervis/Actor/Loom.hs b/src/Vervis/Actor/Loom.hs index fa7ee31..22646d4 100644 --- a/src/Vervis/Actor/Loom.hs +++ b/src/Vervis/Actor/Loom.hs @@ -19,7 +19,7 @@ module Vervis.Actor.Loom where import Control.Applicative -import Control.Exception.Base +import Control.Exception.Base hiding (handle) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack @@ -32,6 +32,7 @@ import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) import Data.Foldable +import Data.HList (HList (..)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text (Text) @@ -570,17 +571,22 @@ loomResolve now loomID (Verse authorIdMsig body) (AP.Resolve uObject) = do return (action, recipientSet, remoteActors, fwdHosts) -loomBehavior :: UTCTime -> LoomId -> ActorMessage Loom -> ActE (Text, Act (), Next) -loomBehavior now loomID (MsgL verse@(Verse _authorIdMsig body)) = +loomVerse :: LoomId -> Verse -> ActE (Text, Act (), Next) +loomVerse loomID verse@(Verse _authorIdMsig body) = do + now <- liftIO getCurrentTime case AP.activitySpecific $ actbActivity body of AP.OfferActivity offer -> loomOffer now loomID verse offer AP.ResolveActivity resolve -> loomResolve now loomID verse resolve _ -> throwE "Unsupported activity type for Loom" -instance VervisActorLaunch Loom where - actorBehavior' now loomID ve = do - errboxID <- lift $ withDB $ do - resourceID <- loomResource <$> getJust loomID - Resource actorID <- getJust resourceID - actorErrbox <$> getJust actorID - adaptErrbox errboxID False loomBehavior now loomID ve +instance ActorLaunch Loom where + actorBehavior _ = + (handleMethod @"verse" := \ loomID verse -> adaptHandlerResult $ do + errboxID <- lift $ withDB $ do + resourceID <- loomResource <$> getJust loomID + Resource actorID <- getJust resourceID + actorErrbox <$> getJust actorID + adaptErrbox errboxID False (loomVerse loomID) verse + ) + `HCons` + HNil diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index c6d59b6..bf1826b 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -20,7 +20,7 @@ module Vervis.Actor.Person where import Control.Applicative -import Control.Exception.Base +import Control.Exception.Base hiding (handle) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack @@ -34,6 +34,7 @@ import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) import Data.Foldable +import Data.HList (HList (..)) import Data.Maybe import Data.Text (Text) import Data.Time.Clock @@ -1569,8 +1570,8 @@ personInit now personMeID = do return (action, recipientSet, remoteActors, fwdHosts) -personBehavior :: UTCTime -> PersonId -> ActorMessage Person -> ActE (Text, Act (), Next) -personBehavior now personID (PersonMsgVerse verse@(Verse _authorIdMsig body)) = +personVerse personID verse@(Verse _authorIdMsig body) = do + now <- liftIO getCurrentTime case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> personAccept now personID verse accept AP.AddActivity add -> personAdd now personID verse add @@ -1590,12 +1591,24 @@ personBehavior now personID (PersonMsgVerse verse@(Verse _authorIdMsig body)) = AP.RevokeActivity revoke -> personRevoke now personID verse revoke AP.UndoActivity undo -> personUndo now personID verse undo _ -> throwE "Unsupported activity type for Person" -personBehavior now personID (PersonMsgClient msg) = clientBehavior now personID msg -personBehavior now personID PersonMsgInit = personInit now personID -instance VervisActorLaunch Person where - actorBehavior' now personID ve = do - errboxID <- lift $ withDB $ do - actorID <- personActor <$> getJust personID - actorErrbox <$> getJust actorID - adaptErrbox errboxID True personBehavior now personID ve +instance ActorLaunch Person where + actorBehavior _ = + (handleMethod @"verse" := \ personID verse -> adaptHandlerResult $ do + errboxID <- lift $ withDB $ do + actorID <- personActor <$> getJust personID + actorErrbox <$> getJust actorID + adaptErrbox errboxID True (personVerse personID) verse + ) + `HCons` + (handleMethod @"client" := \ personID msg -> adaptHandlerResult $ do + now <- liftIO getCurrentTime + clientBehavior now personID msg + ) + `HCons` + (handleMethod @"init" := \ personID -> adaptHandlerResult $ do + now <- liftIO getCurrentTime + personInit now personID + ) + `HCons` + HNil diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index e6cbd67..49b90ee 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -1210,9 +1210,10 @@ clientUndo now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts fwdHosts undoID action return undoID -clientBehavior :: UTCTime -> PersonId -> ClientMsg -> ActE (Text, Act (), Next) +clientBehavior + :: UTCTime -> PersonId -> ClientMsg -> ActE (OutboxItemId, Act (), Next) clientBehavior now personID msg = - done . T.pack . show =<< + done =<< case AP.actionSpecific $ cmAction msg of AP.AcceptActivity accept -> clientAccept now personID msg accept AP.AddActivity add -> clientAdd now personID msg add diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index afd92dd..e273b9a 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -19,7 +19,7 @@ module Vervis.Actor.Project where import Control.Applicative -import Control.Exception.Base +import Control.Exception.Base hiding (handle) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack @@ -34,6 +34,7 @@ import Data.Bitraversable import Data.ByteString (ByteString) import Data.Either import Data.Foldable +import Data.HList (HList (..)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text (Text) @@ -7577,8 +7578,9 @@ projectUndo now recipProjectID (Verse authorIdMsig body) (AP.Undo uObject) = do return (action, recipientSet, remoteActors, fwdHosts) -projectBehavior :: UTCTime -> ProjectId -> ActorMessage Project -> ActE (Text, Act (), Next) -projectBehavior now projectID (ProjectMsgVerse verse@(Verse _authorIdMsig body)) = +projectVerse :: ProjectId -> Verse -> ActE (Text, Act (), Next) +projectVerse projectID verse@(Verse _authorIdMsig body) = do + now <- liftIO getCurrentTime case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> projectAccept now projectID verse accept AP.AddActivity add -> projectAdd now projectID verse add @@ -7591,14 +7593,21 @@ projectBehavior now projectID (ProjectMsgVerse verse@(Verse _authorIdMsig body)) AP.RevokeActivity revoke -> projectRevoke now projectID verse revoke AP.UndoActivity undo -> projectUndo now projectID verse undo _ -> throwE "Unsupported activity type for Project" -projectBehavior now projectID (ProjectMsgInit creator) = - let grabResource = pure . projectResource - in topicInit grabResource LocalResourceProject now projectID creator -instance VervisActorLaunch Project where - actorBehavior' now projectID ve = do - errboxID <- lift $ withDB $ do - resourceID <- projectResource <$> getJust projectID - Resource actorID <- getJust resourceID - actorErrbox <$> getJust actorID - adaptErrbox errboxID False projectBehavior now projectID ve +instance ActorLaunch Project where + actorBehavior _ = + (handleMethod @"verse" := \ projectID verse -> adaptHandlerResult $ do + errboxID <- lift $ withDB $ do + resourceID <- projectResource <$> getJust projectID + Resource actorID <- getJust resourceID + actorErrbox <$> getJust actorID + adaptErrbox errboxID False (projectVerse projectID) verse + ) + `HCons` + (handleMethod @"init" := \ projectID creator -> adaptHandlerResult $ do + now <- liftIO getCurrentTime + let grabResource = pure . projectResource + topicInit grabResource LocalResourceProject now projectID creator + ) + `HCons` + HNil diff --git a/src/Vervis/Actor/Repo.hs b/src/Vervis/Actor/Repo.hs index 17bd00f..f19b5e1 100644 --- a/src/Vervis/Actor/Repo.hs +++ b/src/Vervis/Actor/Repo.hs @@ -26,6 +26,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.ByteString (ByteString) import Data.Foldable +import Data.HList (HList (..)) import Data.Text (Text) import Data.Time.Clock import Database.Persist @@ -53,18 +54,25 @@ import Vervis.Persist.Actor import Vervis.Persist.Discussion import Vervis.Ticket -repoBehavior :: UTCTime -> RepoId -> ActorMessage Repo -> ActE (Text, Act (), Next) -repoBehavior now repoID (MsgR (Left _verse@(Verse _authorIdMsig body))) = +repoVerse :: RepoId -> Verse -> ActE (Text, Act (), Next) +repoVerse repoID _verse@(Verse _authorIdMsig body) = do + now <- liftIO getCurrentTime case AP.activitySpecific $ actbActivity body of _ -> throwE "Unsupported activity type for Repo" -repoBehavior _now _repoID (MsgR (Right waitValue)) = do - liftIO waitValue - done "Waited for push to complete" -instance VervisActorLaunch Repo where - actorBehavior' now repoID ve = do - errboxID <- lift $ withDB $ do - resourceID <- repoResource <$> getJust repoID - Resource actorID <- getJust resourceID - actorErrbox <$> getJust actorID - adaptErrbox errboxID False repoBehavior now repoID ve +instance ActorLaunch Repo where + actorBehavior _ = + (handleMethod @"verse" := \ repoID verse -> adaptHandlerResult $ do + errboxID <- lift $ withDB $ do + resourceID <- repoResource <$> getJust repoID + Resource actorID <- getJust resourceID + actorErrbox <$> getJust actorID + adaptErrbox errboxID False (repoVerse repoID) verse + ) + `HCons` + (handleMethod @"wait-during-push" := \ repoID waitValue -> adaptHandlerResult $ do + liftIO waitValue + done "Waited for push to complete" + ) + `HCons` + HNil diff --git a/src/Vervis/Actor2.hs b/src/Vervis/Actor2.hs index 893086f..c88729e 100644 --- a/src/Vervis/Actor2.hs +++ b/src/Vervis/Actor2.hs @@ -65,7 +65,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.List.NonEmpty as NE import qualified Data.Text as T -import Control.Concurrent.Actor +import Control.Concurrent.Actor hiding (Handler) import Network.FedURI import Web.Actor import Web.Actor.Deliver diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index be761a2..28c281b 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -100,7 +100,7 @@ import Yesod.Hashids import Yesod.MonadSite import Control.Concurrent.Local -import Data.Git.Local (isGitRepo) +import Development.Git (isGitRepo) import Data.List.NonEmpty.Local import Web.Hashids.Local diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index 5e2b6af..c322b14 100644 --- a/src/Vervis/Darcs.hs +++ b/src/Vervis/Darcs.hs @@ -30,12 +30,10 @@ import Prelude hiding (lookup) import Control.Applicative ((<|>)) import Control.Exception.Base +import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except -import Darcs.Util.Path -import Darcs.Util.Tree -import Darcs.Util.Tree.Hashed import Data.Bifunctor import Data.Bool (bool) import Data.ByteString (ByteString) @@ -48,12 +46,6 @@ import Data.Text.Encoding.Error (strictDecode) import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime) import Data.Traversable (for) import Database.Persist -import Development.Darcs.Internal.Hash.Codec -import Development.Darcs.Internal.Hash.Types -import Development.Darcs.Internal.Inventory.Parser -import Development.Darcs.Internal.Inventory.Read -import Development.Darcs.Internal.Inventory.Types -import Development.Darcs.Internal.Patch.Types import System.Exit import System.FilePath (()) import System.Process.Typed @@ -71,14 +63,16 @@ import qualified Data.Text.Encoding as TE import qualified Data.Vector as V (empty) import qualified Database.Esqueleto as E -import qualified Development.Darcs.Internal.Patch.Parser as P - +import Data.ObjId +import Development.Darcs +import Development.PatchMediaType import Network.FedURI import Yesod.ActivityPub import Yesod.Hashids import Yesod.MonadSite -import Darcs.Local.Repository +import qualified Data.VersionControl as VC + import Data.Either.Local (maybeRight) import Data.EventTime.Local import Data.List.Local @@ -88,88 +82,50 @@ import Data.Text.UTF8.Local (decodeStrict) import Data.Time.Clock.Local () import System.Process.Typed.Local -import qualified Data.Patch.Local as DP +import qualified Data.Patch.Local as P import qualified Data.Text.UTF8.Local as TU import Vervis.Changes import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident -import Development.PatchMediaType import Vervis.Path import Vervis.Readme import Vervis.Settings import Vervis.SourceTree -dirToAnchoredPath :: [EntryName] -> AnchoredPath -dirToAnchoredPath = AnchoredPath . map (decodeWhiteName . encodeUtf8) - -matchType :: ItemType -> EntryType -matchType TreeType = TypeTree -matchType BlobType = TypeBlob - -nameToText :: Name -> Text -nameToText = decodeUtf8With strictDecode . encodeWhiteName - -itemToEntry :: Name -> TreeItem IO -> DirEntry -itemToEntry name item = DirEntry (matchType $ itemType item) (nameToText name) - -findReadme :: [(Name, TreeItem IO)] -> IO (Maybe (Text, Text)) -findReadme pairs = - case F.find (isReadme . nameToText . fst) pairs of - Nothing -> return Nothing - Just (name, item) -> - case item of - File (Blob load _hash) -> do - content <- load - content' <- either throwIO return $ TE.decodeUtf8' $ BL.toStrict content - return $ Just (nameToText name, content') - _ -> return Nothing - -itemToSourceView :: EntryName -> TreeItem IO -> IO (SourceView Text) -itemToSourceView name (File (Blob load _hash)) = do - content <- load - content' <- either throwIO return $ TE.decodeUtf8' $ BL.toStrict content - return $ SourceFile $ FileView name content' -itemToSourceView name (SubTree tree) = do - let items = listImmediate tree - mreadme <- findReadme items - return $ SourceDir DirectoryView - { dvName = Just name - , dvEntries = map (uncurry itemToEntry) items - , dvReadme = mreadme - } -itemToSourceView _name (Stub _load _hash) = error "supposed to be expanded" - -readStubbedTree :: FilePath -> IO (Tree IO) -readStubbedTree path = do - let darcsDir = path "_darcs" - (msize, hash) <- readPristineRoot darcsDir - let pristineDir = darcsDir "pristine.hashed" - readDarcsHashed pristineDir (msize, hash) +findReadme :: Text -> FilePath -> DirTree -> DarcsT IO (Maybe (Text, Text)) +findReadme patch dirPath (DirTree _ files) = + for (F.find (isReadme . T.pack) files) $ \ name -> do + body <- darcsGetFileContent patch $ dirPath name + return (T.pack name, body) readSourceView - :: FilePath - -- ^ Repository path - -> [EntryName] + :: [EntryName] -- ^ Path in the source tree pointing to a file or directory - -> IO (Maybe (SourceView Widget)) -readSourceView path dir = do - stubbedTree <- readStubbedTree path - msv <- if null dir - then do - let items = listImmediate stubbedTree - mreadme <- findReadme items - return $ Just $ SourceDir DirectoryView - { dvName = Nothing - , dvEntries = map (uncurry itemToEntry) items - , dvReadme = mreadme - } - else do - let anch = dirToAnchoredPath dir - expandedTree <- expandPath stubbedTree anch - let mitem = find expandedTree anch - for mitem $ itemToSourceView (last dir) + -> DarcsT IO (Maybe (SourceView Widget)) +readSourceView dir = do + let invalid t = T.null t || t == "." || t == ".." || T.any (== '/') t + when (any invalid dir) $ + error $ "readSourceView invalid dir: " ++ show dir + hash <- darcsGetHead + top <- darcsGetTree hash + msv <- for (lookupTreeItem (map T.unpack dir) top) $ \case + Left () -> do + let dir' = T.unpack $ T.intercalate "/" dir + body <- darcsGetFileContent hash dir' + return $ SourceFile $ FileView (last dir) body + Right tree@(DirTree subdirs files) -> do + let dir' = T.unpack $ T.intercalate "/" dir + mreadme <- findReadme hash dir' tree + let mname = + if null dir + then Nothing + else Just $ last dir + ents = + map (DirEntry TypeTree . T.pack . fst) subdirs ++ + map (DirEntry TypeBlob . T.pack) files + return $ SourceDir $ DirectoryView mname ents mreadme return $ renderSources dir <$> msv {- @@ -225,33 +181,31 @@ readWikiView isPage isMain path dir = do -} readChangesView - :: FilePath - -- ^ Repository path - -> Int + :: MonadIO m + => Int -- ^ Offset, i.e. latest patches to skip -> Int -- ^ Limit, i.e. how many latest patches to take after the offset - -> IO (Maybe (Int, [LogEntry])) + -> DarcsT m (Maybe (Int, [LogEntry])) -- ^ Total number of changes, and view of the chosen subset -readChangesView path off lim = fmap maybeRight $ runExceptT $ do - total <- ExceptT $ readLatestInventory path latestInventorySizeP - let off' = total - off - lim - ps <- ExceptT $ readLatestInventory path $ latestInventoryPageP off' lim - now <- lift getCurrentTime - let toLE (pi, h, _) = LogEntry - { leAuthor = - T.stripEnd $ T.takeWhile (/= '<') $ piAuthor pi - , leHash = decodeStrict $ encodePatchInfoHash h - , leMessage = piTitle pi +readChangesView off lim = fmap maybeRight $ runExceptT $ lift $ do + cs <- darcsLog (Just lim) (Just off) + total <- darcsLogLength + now <- liftIO getCurrentTime + let toLE c = LogEntry + { leAuthor = VC.authorName $ fst $ VC.commitWritten c + , leHash = VC.commitHash c + , leMessage = VC.commitTitle c , leTime = - ( piTime pi + ( snd $ VC.commitWritten c , intervalToEventTime $ FriendlyConvert $ - now `diffUTCTime` piTime pi + now `diffUTCTime` snd (VC.commitWritten c) ) } - return (total, map toLE $ reverse $ snd ps) + return (total, map toLE cs) +{- lastChange :: FilePath -> UTCTime -> IO (Maybe EventTime) lastChange path now = fmap maybeRight $ runExceptT $ do total <- ExceptT $ readLatestInventory path latestInventorySizeP @@ -264,6 +218,7 @@ lastChange path now = fmap maybeRight $ runExceptT $ do intervalToEventTime $ FriendlyConvert $ now `diffUTCTime` piTime pi +-} {- data Change @@ -318,71 +273,18 @@ joinHunks = mkHunk (line, (adds, pairs, rems)) = (False, line, Hunk adds pairs rems) -} --- | Read patch content, both metadata and the actual diff, from a given Darcs --- repository. Preconditions: --- --- * The repo's existence has been verified against the DB --- * The repo dir is assumed to exist. If it doesn't, an exception is thrown. --- * The repository is assumed to be in a consistent state, all the expected --- inventory files and patch files and so on are assumed to exist and have --- the expected format. If not, an exception is thrown. --- * The hash may or may not be found in the repo. If there's no patch in the --- repo with the given hash, 'Nothing' is returned. -readPatch :: FilePath -> Text -> IO (Maybe DP.Patch) -readPatch path hash = handle $ runExceptT $ do - pih <- except $ second PatchInfoHash $ B16.decode $ encodeUtf8 hash - li <- ExceptT $ readLatestInventory path latestInventoryAllP - mp <- loop pih (liPatches li) (fst <$> liPrevTag li) - for mp $ \ (pi, pch) -> do - changes <- - ExceptT $ readCompressedPatch path pch AB.takeByteString -- (P.patch <* A.endOfInput) - changes' <- either (throwE . displayException) return $ TE.decodeUtf8' changes - (an, ae) <- - ExceptT . pure $ A.parseOnly (author <* A.endOfInput) $ piAuthor pi - return DP.Patch - { patchWritten = - ( Author - { authorName = an - , authorEmail = ae - } - , piTime pi - ) - , patchCommitted = Nothing - , patchTitle = piTitle pi - , patchDescription = fromMaybe "" $ piDescription pi - , patchDiff = changes' - {- - let (befores, pairs, afters) = groupEithers $ map splitChange changes - befores' = mkedit befores - pairs' = map (bimap arrangeHunks mkedit) pairs - afters' = arrangeHunks <$> nonEmpty afters - in befores' ++ concatMap (NE.toList . uncurry (<>)) pairs' ++ maybe [] NE.toList afters' - -} - } - where - handle a = do - r <- a - case r of - Left e -> fail $ "readPatch failed: " ++ e - Right mp -> return mp - lookup' pih ps = case F.find (\ (_pi, pih', _pch) -> pih' == pih) ps of - Nothing -> Nothing - Just (pi, _pih, pch) -> Just (pi, pch) - loop pih ps mih = case lookup' pih ps of - Just p -> return $ Just p - Nothing -> case mih of - Nothing -> return Nothing - Just ih -> do - i <- ExceptT $ readCompressedInventory path ih earlyInventoryAllP - case i of - Left ei -> loop pih (eiPatches ei) Nothing - Right mi -> loop pih (miPatches mi) (Just $ miPrevious mi) - email = maybe (fail "invalid email") pure . emailAddress . encodeUtf8 - author = (,) - <$> (T.stripEnd <$> A.takeWhile1 (/= '<')) - <* A.skip (== '<') - <*> (A.takeWhile1 (/= '>') >>= email) - <* A.skip (== '>') +-- Copied from Vervis.Git, perhaps move to a common module? +patch :: Text -> VC.Commit -> P.Patch +patch edits (VC.Commit a c _ t d) = P.Patch (mk a) (mk <$> c) t d edits + where + mk = first mk' + mk' (VC.Author n e) = P.Author n e + +readPatch :: ObjId -> MonadIO m => DarcsT m P.Patch +readPatch oid = do + commit <- darcsShowCommit oid + deltas <- darcsDiff oid + return $ patch deltas commit writePostApplyHooks :: WorkerDB () writePostApplyHooks = do diff --git a/src/Vervis/Data/Discussion.hs b/src/Vervis/Data/Discussion.hs index 57971b2..901878d 100644 --- a/src/Vervis/Data/Discussion.hs +++ b/src/Vervis/Data/Discussion.hs @@ -31,7 +31,7 @@ import Data.Bitraversable import Data.Text (Text) import Data.Time.Clock -import Control.Concurrent.Actor +import Control.Concurrent.Actor hiding (Handler) import Network.FedURI import Web.Actor import Web.Actor.Persist diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs index 3f505f4..2b1a724 100644 --- a/src/Vervis/Federation/Auth.hs +++ b/src/Vervis/Federation/Auth.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2022, 2023 by fr33domlover . + - Written in 2019, 2022, 2023, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -32,7 +32,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Crypto.Hash -import Data.Aeson +import Data.Aeson hiding (Key) import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) @@ -60,6 +60,7 @@ import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import Yesod.Persist.Core import qualified Data.Aeson as A +import qualified Data.Aeson.KeyMap as AM import qualified Data.ByteString as B import qualified Data.ByteArray as BA import qualified Data.ByteString.Lazy as BL @@ -149,7 +150,7 @@ verifyIntegrityProof object host luActor (AP.Proof config sig) = case key of PublicVerifKeyEd25519 _ -> return () _ -> throwE "Only jcs-eddsa-2022 i.e. ed25519 keys are supported" - let objectNoProof = HM.delete "proof" object + let objectNoProof = AM.delete "proof" object configLB = A.encode $ Doc host config bodyLB = A.encode objectNoProof configHash = hashWith SHA256 $ BL.toStrict configLB diff --git a/src/Vervis/Fetch.hs b/src/Vervis/Fetch.hs index ce5a3e5..6ed34ab 100644 --- a/src/Vervis/Fetch.hs +++ b/src/Vervis/Fetch.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022, 2023 by fr33domlover . + - Written in 2022, 2023, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -79,9 +79,9 @@ import Control.Monad.Trans.Except.Local import Data.Either.Local import Database.Persist.Local -import qualified Data.Git.Local as G (createRepo) +import qualified Development.Git as G (createRepo) import qualified Data.Text.UTF8.Local as TU -import qualified Darcs.Local.Repository as D (createRepo) +import qualified Development.Darcs as D (createRepo) --import Vervis.Access import Vervis.Actor diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 46b7853..f483609 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -24,8 +24,11 @@ import Control.Monad import Control.Monad.Logger.CallStack (logWarn) import Control.Monad.Trans.Maybe import Data.ByteString (ByteString) +import Data.Foldable import Data.HashMap.Strict (HashMap) +import Data.HList (HList (..)) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy import Data.Text (Text) import Data.Text.Encoding import Data.Time.Calendar @@ -76,7 +79,7 @@ import Yesod.Mail.Send import qualified Network.HTTP.Signature as S (Algorithm (..)) import qualified Yesod.Hashids as YH -import Control.Concurrent.Actor hiding (Message) +import Control.Concurrent.Actor hiding (Message, Handler) --import Crypto.PublicVerifKey import Network.FedURI import Web.ActivityAccess @@ -722,10 +725,11 @@ instance AccountDB AccountPersistDB' where error "Failed to spawn new Person, somehow ID already in Theater" AccountPersistDB' $ do theater <- asksSite appTheater - there <- liftIO $ sendIO theater personID PersonMsgInit + there <- liftIO $ sendIO' @"init" theater Proxy personID HNil unless there $ error "Failed to find new Person, somehow ID not in Theater" factoryIDs <- runDB $ selectKeysList [] [] + {- let package = (HS.fromList factoryIDs, FactoryMsgVerified personID) liftIO $ sendManyIO theater $ Nothing `H.HCons` @@ -735,6 +739,9 @@ instance AccountDB AccountPersistDB' where Nothing `H.HCons` Nothing `H.HCons` Just package `H.HCons` H.HNil + -} + liftIO $ for_ factoryIDs $ \ (factoryID :: FactoryId) -> + void $ sendIO' @"verified" theater Proxy factoryID (personID `HCons` HNil) setVerifyKey = (morphAPDB .) . setVerifyKey setNewPasswordKey = (morphAPDB .) . setNewPasswordKey setNewPassword = (morphAPDB .) . setNewPassword diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index d46fe74..9e85313 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -62,6 +62,9 @@ import qualified Data.Text.Encoding.Error as TE (lenientDecode) import qualified Data.Vector as V import qualified Database.Esqueleto as E +import Data.ObjId +import Development.Git +import Development.PatchMediaType import Network.FedURI import Yesod.ActivityPub import Yesod.Hashids @@ -73,7 +76,6 @@ import Control.Monad.Trans.Except.Local import Data.ByteString.Char8.Local (takeLine) --import Data.DList.Local import Data.EventTime.Local -import Data.Git.Local import Data.List.Local import Data.Time.Clock.Local import System.Process.Typed.Local @@ -85,7 +87,6 @@ import Vervis.Changes import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident -import Development.PatchMediaType import Vervis.Path import Vervis.Readme import Vervis.Settings diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index d15c166..6544b18 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -92,6 +92,7 @@ import Yesod.Core import Yesod.Form hiding (emailField) import Yesod.Persist.Core +import qualified Data.Aeson.KeyMap as AM import qualified Data.ByteString.Char8 as BC import qualified Data.HashMap.Strict as M import qualified Data.Text as T @@ -739,12 +740,12 @@ notificationForm defs = renderDivs $ mk mk _ _ = error "Missing hidden field?" objectSummary o = - case M.lookup "summary" o of + case AM.lookup "summary" o of Just (String t) | not (T.null t) -> Just t _ -> Nothing objectId o = - case M.lookup "id" o <|> M.lookup "@id" o of + case AM.lookup "id" o <|> AM.lookup "@id" o of Just (String t) | not (T.null t) -> t _ -> error "'id' field not found" diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index b95f1e8..8e7036a 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -154,15 +154,15 @@ import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local import Data.ByteString.Char8.Local (takeLine) import Data.Either.Local -import Data.Git.Local +import Development.Git import Database.Persist.Local import Text.FilePath.Local (breakExt) import Web.Hashids.Local import Yesod.Form.Local import Yesod.Persist.Local -import qualified Data.Git.Local as G (createRepo) -import qualified Darcs.Local.Repository as D (createRepo) +import qualified Development.Git as G (createRepo) +import qualified Development.Darcs as D (createRepo) import Vervis.Access import Vervis.ActivityPub diff --git a/src/Vervis/Hook.hs b/src/Vervis/Hook.hs index d1c7161..0c119ab 100644 --- a/src/Vervis/Hook.hs +++ b/src/Vervis/Hook.hs @@ -73,13 +73,15 @@ import qualified Data.Text.Encoding as TE import qualified Data.Text.IO as TIO import Data.KeyFile +import Data.ObjId import Data.VersionControl +import Development.Darcs +import Development.Git import Network.FedURI import Control.Monad.Trans.Except.Local --import Data.DList.Local import Data.List.NonEmpty.Local -import Data.Git.Local data HookSecret = HookSecret ByteString @@ -300,72 +302,6 @@ reportNewPatches config repo = do Right _resp -> return () where dieT err = TIO.hPutStrLn stderr err >> exitFailure - xml2patch elem = do - unless (elName elem == QName "patch" Nothing Nothing) $ - throwE $ - "Expected , found: " <> T.pack (show $ elName elem) - (name, email) <- do - t <- T.pack <$> findAttrE "author" elem - parseOnlyE authorP t "author" - date <- do - s <- findAttrE "date" elem - case parseTimeM False defaultTimeLocale "%Y%m%d%H%M%S" s of - Nothing -> throwE $ "Date parsing failed: " <> T.pack s - Just t -> return t - hash <- do - t <- T.pack <$> findAttrE "hash" elem - unless (T.length t == 40) $ - throwE $ "Expected a hash string of length 40, got: " <> t - return t - - inverted <- do - s <- findAttrE "inverted" elem - readMaybeE s $ "Unrecognized inverted value: " <> T.pack s - when inverted $ throwE $ "Found inverted patch " <> hash - - title <- T.pack . strContent <$> findChildE "name" elem - description <- do - t <- T.pack . strContent <$> findChildE "comment" elem - parseOnlyE commentP t "comment" - - return Commit - { commitWritten = (Author name email, date) - , commitCommitted = Nothing - , commitHash = hash - , commitTitle = title - , commitDescription = description - } - where - readMaybeE s e = fromMaybeE (readMaybe s) e - findAttrE q e = - let ms = findAttr (QName q Nothing Nothing) e - in fromMaybeE ms $ "Couldn't find attr \"" <> T.pack q <> "\"" - findChildE q e = - case findChildren (QName q Nothing Nothing) e of - [] -> throwE $ "No children named " <> T.pack q - [c] -> return c - _ -> throwE $ "Multiple children named " <> T.pack q - authorP = (,) - <$> (T.stripEnd <$> A.takeWhile1 (/= '<')) - <* A.skip (== '<') - <*> (A.takeWhile1 (/= '>') >>= emailP) - <* A.skip (== '>') - where - emailP - = maybe (fail "Invalid email") pure - . emailAddress - . TE.encodeUtf8 - commentP - = A.string "Ignore-this: " - *> A.takeWhile1 isHexDigit - *> (fromMaybe T.empty <$> - optional (A.endOfLine *> A.endOfLine *> A.takeText) - ) - parseOnlyE p t n = - case A.parseOnly (p <* A.endOfInput) t of - Left e -> - throwE $ T.concat ["Parsing ", n, " failed: ", T.pack e] - Right a -> return a postApply :: IO () postApply = do diff --git a/src/Vervis/KeyFile.hs b/src/Vervis/KeyFile.hs index 56fa673..0e63b45 100644 --- a/src/Vervis/KeyFile.hs +++ b/src/Vervis/KeyFile.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019 by fr33domlover . + - Written in 2019, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -46,11 +46,11 @@ where import Control.Monad.Trans.Reader (runReaderT) import Database.Persist.Schema (SchemaBackend, hasEntities) -import Database.Persist.Schema.SQL () -import Database.Persist.Sql (SqlBackend, ConnectionPool, runSqlPool) +import Database.Persist.Schema () +import Database.Persist.Sql (ConnectionPool, runSqlPool) -- | Check whether we're in the initial setup step, in which we create keys. -- Otherwise, we'll only use existing keys loaded from files. -isInitialSetup :: ConnectionPool -> SchemaBackend SqlBackend -> IO Bool +isInitialSetup :: ConnectionPool -> SchemaBackend -> IO Bool isInitialSetup pool sb = flip runSqlPool pool . flip runReaderT (sb, "") $ not <$> hasEntities diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index a8b81e8..fcace4f 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -27,7 +27,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader (ReaderT, runReaderT) -import Data.Aeson +import Data.Aeson hiding (Key) import Data.Bifunctor import Data.ByteString (ByteString) import Data.Default.Class @@ -43,10 +43,9 @@ import Data.Time.Calendar (Day (..)) import Data.Time.Clock import Data.Traversable import Database.Persist -import Database.Persist.BackendDataType (backendDataType, PersistDefault (..)) +import Database.Persist.BackendDataType (PersistDefault (..)) import Database.Persist.Migration import Database.Persist.Schema (SchemaT, Migration) -import Database.Persist.Schema.SQL import Database.Persist.Schema.Types hiding (Entity) import Database.Persist.Schema.PostgreSQL (schemaBackend) import Database.Persist.Sql (SqlBackend, toSqlKey, fromSqlKey) @@ -103,13 +102,12 @@ import Vervis.Settings instance PersistDefault ByteString where pdef = def -type Run m = SchemaT SqlBackend m () -type Mig m = Migration SqlBackend m +type Run m = SchemaT m () defaultTime :: UTCTime defaultTime = UTCTime (ModifiedJulianDay 0) 0 -withPrepare :: Monad m => Mig m -> Run m -> Mig m +withPrepare :: Monad m => Migration m -> Run m -> Migration m withPrepare (validate, apply) prepare = (validate, prepare >> apply) --withPrePost :: Monad m => Run m -> Mig m -> Run m -> Mig m @@ -129,7 +127,9 @@ renameUnique' entity@(EntityName e) old new = (fromString $ "Unique" ++ T.unpack e ++ T.unpack old) (fromString $ "Unique" ++ T.unpack e ++ T.unpack new) -changes :: (MonadSite m, SiteEnv m ~ App) => Host -> HashidsContext -> [Mig m] +changes + :: (MonadSite m, SiteEnv m ~ App) + => Host -> HashidsContext -> [Migration m] changes hLocal ctx = [ -- 1 addEntities model_2016_08_04 @@ -3939,9 +3939,9 @@ migrateDB => Host -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int)) migrateDB hLocal ctx = runExceptT $ do ExceptT $ flip runReaderT (schemaBackend, "") $ runExceptT $ do - foreigns <- lift findMisnamedForeigns + foreigns <- lift S.findMisnamedForeigns unless (null foreigns) $ - throwE $ T.intercalate " ; " (map displayMisnamedForeign foreigns) + throwE $ T.intercalate " ; " (map S.displayMisnamedForeign foreigns) let migrations = changes hLocal ctx (,length migrations) <$> diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index 8d83973..07aaacc 100644 --- a/src/Vervis/Migration/Entities.hs +++ b/src/Vervis/Migration/Entities.hs @@ -89,10 +89,10 @@ import Data.Text (Text) import Data.Time (UTCTime) import Database.Persist.Class (EntityField, Unique) import Database.Persist.EmailAddress () -import Database.Persist.Schema.Types (Entity) -import Database.Persist.Schema.SQL () +import Database.Persist.Schema.Types +import Database.Persist.Schema () import Database.Persist.Schema.TH (makeEntitiesMigration) -import Database.Persist.Sql (SqlBackend) +import Database.Persist.Sql hiding (Entity) import Text.Email.Validate (EmailAddress) import Web.Text (HTML, PandocMarkdown) @@ -119,203 +119,203 @@ import Web.ActivityPub type PersistActivity = PersistJSON (Doc Activity URIMode) -model_2016_08_04 :: [Entity SqlBackend] -model_2016_08_04 = $(schema "2016_08_04") +model_2016_08_04 :: [Entity] +model_2016_08_04 = $$(schema "2016_08_04") -model_2016_09_01_just_workflow :: [Entity SqlBackend] -model_2016_09_01_just_workflow = $(schema "2016_09_01_just_workflow") +model_2016_09_01_just_workflow :: [Entity] +model_2016_09_01_just_workflow = $$(schema "2016_09_01_just_workflow") -model_2016_09_01_rest :: [Entity SqlBackend] -model_2016_09_01_rest = $(schema "2016_09_01_rest") +model_2016_09_01_rest :: [Entity] +model_2016_09_01_rest = $$(schema "2016_09_01_rest") -model_2019_02_03_verifkey :: [Entity SqlBackend] -model_2019_02_03_verifkey = $(schema "2019_02_03_verifkey") +model_2019_02_03_verifkey :: [Entity] +model_2019_02_03_verifkey = $$(schema "2019_02_03_verifkey") -model_2019_03_19 :: [Entity SqlBackend] -model_2019_03_19 = $(schema "2019_03_19") +model_2019_03_19 :: [Entity] +model_2019_03_19 = $$(schema "2019_03_19") -model_2019_03_30 :: [Entity SqlBackend] -model_2019_03_30 = $(schema "2019_03_30") +model_2019_03_30 :: [Entity] +model_2019_03_30 = $$(schema "2019_03_30") -model_2019_04_11 :: [Entity SqlBackend] -model_2019_04_11 = $(schema "2019_04_11") +model_2019_04_11 :: [Entity] +model_2019_04_11 = $$(schema "2019_04_11") -model_2019_04_12 :: [Entity SqlBackend] -model_2019_04_12 = $(schema "2019_04_12") +model_2019_04_12 :: [Entity] +model_2019_04_12 = $$(schema "2019_04_12") -model_2019_04_22 :: [Entity SqlBackend] -model_2019_04_22 = $(schema "2019_04_22") +model_2019_04_22 :: [Entity] +model_2019_04_22 = $$(schema "2019_04_22") -model_2019_05_03 :: [Entity SqlBackend] -model_2019_05_03 = $(schema "2019_05_03") +model_2019_05_03 :: [Entity] +model_2019_05_03 = $$(schema "2019_05_03") -model_2019_05_17 :: [Entity SqlBackend] -model_2019_05_17 = $(schema "2019_05_17") +model_2019_05_17 :: [Entity] +model_2019_05_17 = $$(schema "2019_05_17") -model_2019_06_06 :: [Entity SqlBackend] -model_2019_06_06 = $(schema "2019_06_06") +model_2019_06_06 :: [Entity] +model_2019_06_06 = $$(schema "2019_06_06") -model_2019_09_25 :: [Entity SqlBackend] -model_2019_09_25 = $(schema "2019_09_25") +model_2019_09_25 :: [Entity] +model_2019_09_25 = $$(schema "2019_09_25") -model_2019_11_04 :: [Entity SqlBackend] -model_2019_11_04 = $(schema "2019_11_04") +model_2019_11_04 :: [Entity] +model_2019_11_04 = $$(schema "2019_11_04") -model_2020_01_05 :: [Entity SqlBackend] -model_2020_01_05 = $(schema "2020_01_05") +model_2020_01_05 :: [Entity] +model_2020_01_05 = $$(schema "2020_01_05") -model_2020_02_05 :: [Entity SqlBackend] -model_2020_02_05 = $(schema "2020_02_05_local_ticket") +model_2020_02_05 :: [Entity] +model_2020_02_05 = $$(schema "2020_02_05_local_ticket") -model_2020_02_07 :: [Entity SqlBackend] -model_2020_02_07 = $(schema "2020_02_07_tpl") +model_2020_02_07 :: [Entity] +model_2020_02_07 = $$(schema "2020_02_07_tpl") -model_2020_02_09 :: [Entity SqlBackend] -model_2020_02_09 = $(schema "2020_02_09_tup") +model_2020_02_09 :: [Entity] +model_2020_02_09 = $$(schema "2020_02_09_tup") -model_2020_02_22 :: [Entity SqlBackend] -model_2020_02_22 = $(schema "2020_02_22_tpr") +model_2020_02_22 :: [Entity] +model_2020_02_22 = $$(schema "2020_02_22_tpr") -model_2020_04_07 :: [Entity SqlBackend] -model_2020_04_07 = $(schema "2020_04_07_tpra") +model_2020_04_07 :: [Entity] +model_2020_04_07 = $$(schema "2020_04_07_tpra") -model_2020_04_09 :: [Entity SqlBackend] -model_2020_04_09 = $(schema "2020_04_09_rt") +model_2020_04_09 :: [Entity] +model_2020_04_09 = $$(schema "2020_04_09_rt") -model_2020_05_12 :: [Entity SqlBackend] -model_2020_05_12 = $(schema "2020_05_12_fwd_sender") +model_2020_05_12 :: [Entity] +model_2020_05_12 = $$(schema "2020_05_12_fwd_sender") -model_2020_05_16 :: [Entity SqlBackend] -model_2020_05_16 = $(schema "2020_05_16_tcl") +model_2020_05_16 :: [Entity] +model_2020_05_16 = $$(schema "2020_05_16_tcl") -model_2020_05_17 :: [Entity SqlBackend] -model_2020_05_17 = $(schema "2020_05_17_patch") +model_2020_05_17 :: [Entity] +model_2020_05_17 = $$(schema "2020_05_17_patch") -model_2020_05_25 :: [Entity SqlBackend] -model_2020_05_25 = $(schema "2020_05_25_fwd_sender_repo") +model_2020_05_25 :: [Entity] +model_2020_05_25 = $$(schema "2020_05_25_fwd_sender_repo") -model_2020_05_28 :: [Entity SqlBackend] -model_2020_05_28 = $(schema "2020_05_28_tda") +model_2020_05_28 :: [Entity] +model_2020_05_28 = $$(schema "2020_05_28_tda") -model_2020_06_01 :: [Entity SqlBackend] -model_2020_06_01 = $(schema "2020_06_01_tdc") +model_2020_06_01 :: [Entity] +model_2020_06_01 = $$(schema "2020_06_01_tdc") -model_2020_06_18 :: [Entity SqlBackend] -model_2020_06_18 = $(schema "2020_06_18_tdo") +model_2020_06_18 :: [Entity] +model_2020_06_18 = $$(schema "2020_06_18_tdo") -model_2020_07_23 :: [Entity SqlBackend] -model_2020_07_23 = $(schema "2020_07_23_remote_collection_reboot") +model_2020_07_23 :: [Entity] +model_2020_07_23 = $$(schema "2020_07_23_remote_collection_reboot") -model_2020_07_27 :: [Entity SqlBackend] -model_2020_07_27 = $(schema "2020_07_27_ticket_resolve") +model_2020_07_27 :: [Entity] +model_2020_07_27 = $$(schema "2020_07_27_ticket_resolve") -model_2020_08_10 :: [Entity SqlBackend] -model_2020_08_10 = $(schema "2020_08_10_bundle") +model_2020_08_10 :: [Entity] +model_2020_08_10 = $$(schema "2020_08_10_bundle") -model_2022_06_14 :: [Entity SqlBackend] -model_2022_06_14 = $(schema "2022_06_14_collab") +model_2022_06_14 :: [Entity] +model_2022_06_14 = $$(schema "2022_06_14_collab") -model_2022_07_17 :: [Entity SqlBackend] -model_2022_07_17 = $(schema "2022_07_17_actor") +model_2022_07_17 :: [Entity] +model_2022_07_17 = $$(schema "2022_07_17_actor") -model_2022_07_24 :: [Entity SqlBackend] -model_2022_07_24 = $(schema "2022_07_24_collab_fulfills") +model_2022_07_24 :: [Entity] +model_2022_07_24 = $$(schema "2022_07_24_collab_fulfills") -model_384_loom :: [Entity SqlBackend] -model_384_loom = $(schema "384_2022-08-04_loom") +model_384_loom :: [Entity] +model_384_loom = $$(schema "384_2022-08-04_loom") -model_386_assignee :: [Entity SqlBackend] -model_386_assignee = $(schema "386_2022-08-04_assignee") +model_386_assignee :: [Entity] +model_386_assignee = $$(schema "386_2022-08-04_assignee") -model_399_fwder :: [Entity SqlBackend] -model_399_fwder = $(schema "399_2022-08-04_fwder") +model_399_fwder :: [Entity] +model_399_fwder = $$(schema "399_2022-08-04_fwder") -model_408_collab_loom :: [Entity SqlBackend] -model_408_collab_loom = $(schema "408_2022-08-04_collab_loom") +model_408_collab_loom :: [Entity] +model_408_collab_loom = $$(schema "408_2022-08-04_collab_loom") -model_425_collab_accept :: [Entity SqlBackend] -model_425_collab_accept = $(schema "425_2022-08-21_collab_accept") +model_425_collab_accept :: [Entity] +model_425_collab_accept = $$(schema "425_2022-08-21_collab_accept") -model_428_collab_topic_local :: [Entity SqlBackend] -model_428_collab_topic_local = $(schema "428_2022-08-29_collab_topic_local") +model_428_collab_topic_local :: [Entity] +model_428_collab_topic_local = $$(schema "428_2022-08-29_collab_topic_local") -model_451_collab_remote_accept :: [Entity SqlBackend] -model_451_collab_remote_accept = $(schema "451_2022-08-30_collab_remote_accept") +model_451_collab_remote_accept :: [Entity] +model_451_collab_remote_accept = $$(schema "451_2022-08-30_collab_remote_accept") -model_453_collab_receive :: [Entity SqlBackend] -model_453_collab_receive = $(schema "453_2022-09-01_collab_receive") +model_453_collab_receive :: [Entity] +model_453_collab_receive = $$(schema "453_2022-09-01_collab_receive") -model_494_mr_origin :: [Entity SqlBackend] -model_494_mr_origin = $(schema "494_2022-09-17_mr_origin") +model_494_mr_origin :: [Entity] +model_494_mr_origin = $$(schema "494_2022-09-17_mr_origin") -model_497_sigkey :: [Entity SqlBackend] -model_497_sigkey = $(schema "497_2022-09-29_sigkey") +model_497_sigkey :: [Entity] +model_497_sigkey = $$(schema "497_2022-09-29_sigkey") -model_508_invite :: [Entity SqlBackend] -model_508_invite = $(schema "508_2022-10-19_invite") +model_508_invite :: [Entity] +model_508_invite = $$(schema "508_2022-10-19_invite") -model_530_join :: [Entity SqlBackend] -model_530_join = $(schema "530_2022-11-01_join") +model_530_join :: [Entity] +model_530_join = $$(schema "530_2022-11-01_join") -model_531_follow_request :: [Entity SqlBackend] -model_531_follow_request = $(schema "531_2023-06-15_follow_request") +model_531_follow_request :: [Entity] +model_531_follow_request = $$(schema "531_2023-06-15_follow_request") -model_541_project :: [Entity SqlBackend] -model_541_project = $(schema "541_2023-06-26_project") +model_541_project :: [Entity] +model_541_project = $$(schema "541_2023-06-26_project") -model_542_component :: [Entity SqlBackend] -model_542_component = $(schema "542_2023-06-26_component") +model_542_component :: [Entity] +model_542_component = $$(schema "542_2023-06-26_component") -model_551_group_collab :: [Entity SqlBackend] -model_551_group_collab = $(schema "551_2023-11-21_group_collab") +model_551_group_collab :: [Entity] +model_551_group_collab = $$(schema "551_2023-11-21_group_collab") -model_552_collab_deleg :: [Entity SqlBackend] -model_552_collab_deleg = $(schema "552_2023-11-21_collab_deleg") +model_552_collab_deleg :: [Entity] +model_552_collab_deleg = $$(schema "552_2023-11-21_collab_deleg") -model_564_permit :: [Entity SqlBackend] -model_564_permit = $(schema "564_2023-11-22_permit") +model_564_permit :: [Entity] +model_564_permit = $$(schema "564_2023-11-22_permit") -model_570_source_dest :: [Entity SqlBackend] -model_570_source_dest = $(schema "570_2023-12-09_source_dest") +model_570_source_dest :: [Entity] +model_570_source_dest = $$(schema "570_2023-12-09_source_dest") -model_577_component_gather :: [Entity SqlBackend] -model_577_component_gather = $(schema "577_2024-03-13_component_gather") +model_577_component_gather :: [Entity] +model_577_component_gather = $$(schema "577_2024-03-13_component_gather") -model_578_source_remove :: [Entity SqlBackend] -model_578_source_remove = $(schema "578_2024-04-03_source_remove") +model_578_source_remove :: [Entity] +model_578_source_remove = $$(schema "578_2024-04-03_source_remove") -model_583_dest_start :: [Entity SqlBackend] -model_583_dest_start = $(schema "583_2024-04-13_dest_start") +model_583_dest_start :: [Entity] +model_583_dest_start = $$(schema "583_2024-04-13_dest_start") -model_591_component_gather :: [Entity SqlBackend] -model_591_component_gather = $(schema "591_2024-04-14_component_gather") +model_591_component_gather :: [Entity] +model_591_component_gather = $$(schema "591_2024-04-14_component_gather") -model_592_permit_extend :: [Entity SqlBackend] -model_592_permit_extend = $(schema "592_2024-04-18_permit_extend") +model_592_permit_extend :: [Entity] +model_592_permit_extend = $$(schema "592_2024-04-18_permit_extend") -model_601_permit_extend_resource :: [Entity SqlBackend] +model_601_permit_extend_resource :: [Entity] model_601_permit_extend_resource = - $(schema "601_2024-04-18_permit_extend_resource") + $$(schema "601_2024-04-18_permit_extend_resource") -model_603_resource :: [Entity SqlBackend] -model_603_resource = $(schema "603_2024-04-20_resource") +model_603_resource :: [Entity] +model_603_resource = $$(schema "603_2024-04-20_resource") -model_626_komponent :: [Entity SqlBackend] -model_626_komponent = $(schema "626_2024-04-29_komponent") +model_626_komponent :: [Entity] +model_626_komponent = $$(schema "626_2024-04-29_komponent") -model_638_effort_squad :: [Entity SqlBackend] -model_638_effort_squad = $(schema "638_2024-05-14_effort_squad") +model_638_effort_squad :: [Entity] +model_638_effort_squad = $$(schema "638_2024-05-14_effort_squad") -model_639_component_convey :: [Entity SqlBackend] -model_639_component_convey = $(schema "639_2024-05-14_component_convey") +model_639_component_convey :: [Entity] +model_639_component_convey = $$(schema "639_2024-05-14_component_convey") type ListOfByteStrings = [ByteString] -model_648_report :: [Entity SqlBackend] -model_648_report = $(schema "648_2024-07-06_report") +model_648_report :: [Entity] +model_648_report = $$(schema "648_2024-07-06_report") -model_649_factory :: [Entity SqlBackend] -model_649_factory = $(schema "649_2024-07-29_factory") +model_649_factory :: [Entity] +model_649_factory = $$(schema "649_2024-07-29_factory") -model_650_fulfills_resident :: [Entity SqlBackend] -model_650_fulfills_resident = $(schema "650_2024-08-03_fulfills_resident") +model_650_fulfills_resident :: [Entity] +model_650_fulfills_resident = $$(schema "650_2024-08-03_fulfills_resident") diff --git a/src/Vervis/Migration/Model2016.hs b/src/Vervis/Migration/Model2016.hs index c73799e..c674c18 100644 --- a/src/Vervis/Migration/Model2016.hs +++ b/src/Vervis/Migration/Model2016.hs @@ -34,7 +34,7 @@ import Data.Time (UTCTime) import Database.Persist.Class (EntityField, Unique) import Database.Persist.EmailAddress () import Database.Persist.Schema.Types (Entity) -import Database.Persist.Schema.SQL () +import Database.Persist.Schema () import Database.Persist.Schema.TH (makeEntitiesMigration) import Database.Persist.Sql (SqlBackend) import Text.Email.Validate (EmailAddress) diff --git a/src/Vervis/Migration/Model2018.hs b/src/Vervis/Migration/Model2018.hs index e9b5d8a..b6e9355 100644 --- a/src/Vervis/Migration/Model2018.hs +++ b/src/Vervis/Migration/Model2018.hs @@ -30,7 +30,7 @@ import Data.Time (UTCTime) import Database.Persist.Class (EntityField, Unique) import Database.Persist.EmailAddress () import Database.Persist.Schema.Types (Entity) -import Database.Persist.Schema.SQL () +import Database.Persist.Schema () import Database.Persist.Schema.TH (makeEntitiesMigration) import Database.Persist.Sql (SqlBackend) import Text.Email.Validate (EmailAddress) diff --git a/src/Vervis/Migration/Model2019.hs b/src/Vervis/Migration/Model2019.hs index 4291ccc..d4f4b1e 100644 --- a/src/Vervis/Migration/Model2019.hs +++ b/src/Vervis/Migration/Model2019.hs @@ -134,7 +134,7 @@ import Data.Time (UTCTime) import Database.Persist.Class (EntityField, Unique) import Database.Persist.EmailAddress () import Database.Persist.Schema.Types (Entity) -import Database.Persist.Schema.SQL () +import Database.Persist.Schema () import Database.Persist.Schema.TH (makeEntitiesMigration) import Database.Persist.Sql (SqlBackend) import Text.Email.Validate (EmailAddress) diff --git a/src/Vervis/Migration/Model2020.hs b/src/Vervis/Migration/Model2020.hs index 156dc54..833fd88 100644 --- a/src/Vervis/Migration/Model2020.hs +++ b/src/Vervis/Migration/Model2020.hs @@ -120,7 +120,7 @@ import Data.Time (UTCTime) import Database.Persist.Class (EntityField, Unique) import Database.Persist.EmailAddress () import Database.Persist.Schema.Types (Entity) -import Database.Persist.Schema.SQL () +import Database.Persist.Schema () import Database.Persist.Schema.TH (makeEntitiesMigration) import Database.Persist.Sql (SqlBackend) import Text.Email.Validate (EmailAddress) diff --git a/src/Vervis/Migration/Model2022.hs b/src/Vervis/Migration/Model2022.hs index bb1244c..e750698 100644 --- a/src/Vervis/Migration/Model2022.hs +++ b/src/Vervis/Migration/Model2022.hs @@ -63,7 +63,7 @@ import Data.Time (UTCTime) import Database.Persist.Class (EntityField, Unique) import Database.Persist.EmailAddress () import Database.Persist.Schema.Types (Entity) -import Database.Persist.Schema.SQL () +import Database.Persist.Schema () import Database.Persist.Schema.TH (makeEntitiesMigration) import Database.Persist.Sql (SqlBackend) import Text.Email.Validate (EmailAddress) diff --git a/src/Vervis/Migration/Model2023.hs b/src/Vervis/Migration/Model2023.hs index c7e98a5..30bf9da 100644 --- a/src/Vervis/Migration/Model2023.hs +++ b/src/Vervis/Migration/Model2023.hs @@ -30,7 +30,7 @@ import Data.Time (UTCTime) import Database.Persist.Class (EntityField, Unique) import Database.Persist.EmailAddress () import Database.Persist.Schema.Types (Entity) -import Database.Persist.Schema.SQL () +import Database.Persist.Schema () import Database.Persist.Schema.TH (makeEntitiesMigration) import Database.Persist.Sql (SqlBackend) import Text.Email.Validate (EmailAddress) diff --git a/src/Vervis/Migration/Model2024.hs b/src/Vervis/Migration/Model2024.hs index ea72529..611d129 100644 --- a/src/Vervis/Migration/Model2024.hs +++ b/src/Vervis/Migration/Model2024.hs @@ -30,7 +30,7 @@ import Data.Time (UTCTime) import Database.Persist.Class (EntityField, Unique) import Database.Persist.EmailAddress () import Database.Persist.Schema.Types (Entity) -import Database.Persist.Schema.SQL () +import Database.Persist.Schema () import Database.Persist.Schema.TH (makeEntitiesMigration) import Database.Persist.Sql (SqlBackend) import Text.Email.Validate (EmailAddress) diff --git a/src/Vervis/Migration/TH.hs b/src/Vervis/Migration/TH.hs index 84f6b06..0773d58 100644 --- a/src/Vervis/Migration/TH.hs +++ b/src/Vervis/Migration/TH.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2018 by fr33domlover . + - Written in 2018, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -18,10 +18,11 @@ module Vervis.Migration.TH ) where -import Database.Persist.Schema.TH (entitiesFromFile) -import Language.Haskell.TH (Q, Exp) -import System.FilePath ((), (<.>)) +import Database.Persist.Schema.TH +import Database.Persist.Schema.Types +import Language.Haskell.TH +import System.FilePath -- | Makes expression of type [Database.Persist.Schema.Entity] -schema :: String -> Q Exp +schema :: String -> Code Q [Entity] schema s = entitiesFromFile $ "migrations" s <.> "model" diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index 4e43719..403629c 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -58,7 +58,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader -import Data.Aeson +import Data.Aeson hiding (Key) import Data.Barbie import Data.ByteString (ByteString) import Data.Bitraversable @@ -89,6 +89,7 @@ import Control.Monad.Trans.Except.Local import Data.Maybe.Local import Database.Persist.Local +import Vervis.Actor (Verse) import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.FedURI @@ -434,24 +435,21 @@ insertToInbox now (Right (author, luAct, _)) body inboxID unread = do Just _ -> return $ Just (ibiid, Right (author, luAct, ractid)) adaptErrbox - :: VA.VervisActor a - => InboxId + :: InboxId -> Bool - -> (UTCTime -> ActorKey a -> ActorMessage a -> VA.ActE (Text, VA.Act (), Next)) - -> UTCTime -> ActorKey a -> ActorMessage a -> VA.ActE (Text, VA.Act (), Next) -adaptErrbox inboxID unread behavior now key msg = - case VA.toVerse msg of - Nothing -> behavior now key msg - Just (VA.Verse authorIdMsig body) -> do - result <- lift $ runExceptT $ behavior now key msg - case result of - Right success -> return success - Left err -> do - _ <- lift $ VA.withDB $ runMaybeT $ do - _ <- MaybeT $ get inboxID - (itemID, _) <- MaybeT $ insertToInbox now authorIdMsig body inboxID unread - lift $ update itemID [InboxItemResult =. err] - throwE err + -> (Verse -> VA.ActE (Text, VA.Act (), Next)) + -> Verse -> VA.ActE (Text, VA.Act (), Next) +adaptErrbox inboxID unread behavior verse@(VA.Verse authorIdMsig body) = do + result <- lift $ runExceptT $ behavior verse + case result of + Right success -> return success + Left err -> do + now <- liftIO getCurrentTime + _ <- lift $ VA.withDB $ runMaybeT $ do + _ <- MaybeT $ get inboxID + (itemID, _) <- MaybeT $ insertToInbox now authorIdMsig body inboxID unread + lift $ update itemID [InboxItemResult =. err] + throwE err getActivityIdent :: MonadIO m diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index cbb7bc3..ed7f3b0 100644 --- a/src/Vervis/Ssh.hs +++ b/src/Vervis/Ssh.hs @@ -29,8 +29,10 @@ import Data.Attoparsec.Text import Data.ByteString (ByteString) import Data.ByteString.Lazy (fromStrict) import Data.Foldable (find) +import Data.HList (HList (..)) import Data.Maybe (isJust) import Data.Monoid ((<>)) +import Data.Proxy import Data.String (fromString) import Data.Text (Text) import Database.Persist @@ -50,11 +52,11 @@ import Yesod.Core.Dispatch import qualified Data.Text as T import qualified Formatting as F -import Control.Concurrent.Actor +import Control.Concurrent.Actor hiding (handle) import Control.Concurrent.Return import Yesod.Hashids -import Data.Git.Local +import Development.Git import Vervis.Access import Vervis.Actor @@ -267,7 +269,7 @@ runAction decodeRepoHash root _wantReply action = liftIO $ setEnv "VERVIS_SSH_USER" (show $ fromSqlKey pid) theater <- lift . lift $ asks snd (sendValue, waitValue) <- liftIO newReturn - _ <- liftIO $ sendIO theater repoID $ MsgR $ Right waitValue + _ <- liftIO $ sendIO' @"wait-during-push" theater Proxy repoID $ waitValue `HCons` HNil executeWait "darcs" ["apply", "--all", "--repodir", repoPath] liftIO $ sendValue () return ARProcess @@ -294,7 +296,7 @@ runAction decodeRepoHash root _wantReply action = liftIO $ setEnv "VERVIS_SSH_USER" (show $ fromSqlKey pid) theater <- lift . lift $ asks snd (sendValue, waitValue) <- liftIO newReturn - _ <- liftIO $ sendIO theater repoID $ MsgR $ Right waitValue + _ <- liftIO $ sendIO' @"wait-during-push" theater Proxy repoID $ waitValue `HCons` HNil executeWait "git-receive-pack" [repoPath] liftIO $ sendValue () return ARProcess diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index bb4c9bc..0a9e712 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -43,15 +43,17 @@ import Control.Monad.Logger.CallStack import Control.Monad.STM (atomically) import Control.Monad.Trans.Except import Control.Monad.Trans.Reader -import Data.Aeson +import Data.Aeson hiding (Key) import Data.Aeson.Encode.Pretty import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) import Data.Foldable (for_) import Data.Hashable +import Data.HList (HList (..)) import Data.List import Data.Maybe +import Data.Proxy import Data.Text (Text) import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Time.Clock @@ -60,6 +62,7 @@ import Data.Time.Units (Second) import Data.Traversable import Database.Persist import Database.Persist.Sql +import Fcf import Network.HTTP.Types.Status import Optics.Core import Text.Blaze.Html (Html, preEscapedToHtml) @@ -73,6 +76,7 @@ import Yesod.Form.Functions import Yesod.Form.Types import Yesod.Persist.Core +import qualified Data.Aeson.KeyMap as AM import qualified Data.ByteString.Char8 as BC (unpack) import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as M @@ -108,7 +112,7 @@ import Yesod.Persist.Local import qualified Data.Aeson.Encode.Pretty.ToEncoding as P import qualified Web.ActivityPub as AP -import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..), VervisActor (..), VervisActorLaunch) +import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..)) import Vervis.Actor2 import Vervis.ActivityPub import Vervis.API @@ -134,12 +138,12 @@ getShowTime = showTime <$> liftIO getCurrentTime diffUTCTime now objectSummary o = - case M.lookup "summary" o of + case AM.lookup "summary" o of Just (String t) | not (T.null t) -> Just t _ -> Nothing objectId o = - case M.lookup "id" o <|> M.lookup "@id" o of + case AM.lookup "id" o <|> AM.lookup "@id" o of Just (String t) | not (T.null t) -> t _ -> error $ @@ -254,9 +258,11 @@ getInbox'' grabInbox here getActorID hash = do postInbox :: ( CCA.Actor a , ActorLaunch a - , VervisActor a + , ActorHasMethod a "verse" (Verse :-> Return (Either Text Text)) + --, Eval (LookupSig "verse" (ActorInterface a)) + -- ~ + -- Just (Verse :-> Return (Either Text Text)) , ActorKey a ~ Key a - , ActorReturn a ~ Either Text Text , Eq (Key a) , Hashable (Key a) , H.HEq @@ -314,7 +320,7 @@ postInbox toLA recipID = do msig <- checkForwarding recipByHash return (author, luActivity, msig) theater <- getsYesod appTheater - r <- liftIO $ callIO theater recipID $ actorVerse $ Verse authorIdMsig body + r <- liftIO $ callIO' @"verse" theater Proxy recipID $ Verse authorIdMsig body `HCons` HNil case r of Nothing -> notFound Just (Left e) -> throwE e diff --git a/src/Vervis/Web/Collab.hs b/src/Vervis/Web/Collab.hs index 2d9876b..2858465 100644 --- a/src/Vervis/Web/Collab.hs +++ b/src/Vervis/Web/Collab.hs @@ -24,7 +24,7 @@ import Control.Exception.Base import Control.Monad import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe -import Data.Aeson +import Data.Aeson hiding (Key) import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) diff --git a/src/Vervis/Web/Darcs.hs b/src/Vervis/Web/Darcs.hs index eef2e0a..ebb5f87 100644 --- a/src/Vervis/Web/Darcs.hs +++ b/src/Vervis/Web/Darcs.hs @@ -48,6 +48,8 @@ import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With) import Data.MediaType +import Data.ObjId +import Development.Darcs import Development.PatchMediaType import Network.FedURI import Yesod.ActivityPub @@ -88,7 +90,7 @@ getDarcsRepoSource :: Repo -> Actor -> KeyHashid Repo -> [Text] -> [LoomId] -> Handler Html getDarcsRepoSource repository actor repo dir loomIDs = do path <- askRepoDir repo - msv <- liftIO $ D.readSourceView path dir + msv <- liftIO $ withDarcsRepo path $ D.readSourceView dir case msv of Nothing -> notFound Just sv -> do @@ -122,7 +124,7 @@ getDarcsRepoChanges repo = do encodeRoutePageLocal <- getEncodeRoutePageLocal let pageUrl = encodeRoutePageLocal here getChanges o l = do - mv <- liftIO $ D.readChangesView path o l + mv <- liftIO $ withDarcsRepo path $ D.readChangesView o l case mv of Nothing -> notFound Just v -> return v @@ -173,7 +175,7 @@ getDarcsRepoChanges repo = do getDarcsPatch :: KeyHashid Repo -> Text -> Handler TypedContent getDarcsPatch hash ref = do path <- askRepoDir hash - mpatch <- liftIO $ D.readPatch path ref - case mpatch of - Nothing -> notFound - Just patch -> serveCommit hash ref patch [] + patch <- liftIO $ do + oid <- parseObjId ref + withDarcsRepo path $ D.readPatch oid + serveCommit hash ref patch [] diff --git a/src/Vervis/Web/Git.hs b/src/Vervis/Web/Git.hs index 8a19740..f0a69aa 100644 --- a/src/Vervis/Web/Git.hs +++ b/src/Vervis/Web/Git.hs @@ -48,6 +48,8 @@ import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With) import Data.MediaType +import Data.ObjId +import Development.Git import Network.FedURI import Yesod.ActivityPub import Yesod.FedURI @@ -58,7 +60,6 @@ import Yesod.RenderSource import qualified Web.ActivityPub as AP import Data.ByteString.Char8.Local (takeLine) -import Data.Git.Local import Data.Paginate.Local import Data.Patch.Local import Text.FilePath.Local (breakExt) diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index f2139c7..481c78e 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -284,6 +284,7 @@ import Yesod.Core.Handler (ProvidedRep, provideRepType) import Network.HTTP.Client.Signature import Web.ActivityPub.Internal +import qualified Data.Aeson.KeyMap as M import qualified Data.Attoparsec.ByteString as A import qualified Data.ByteArray as BA import qualified Data.ByteString as B @@ -291,7 +292,6 @@ import qualified Data.ByteString.Base58 as B58 import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as M import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -719,7 +719,7 @@ parseActorLocal o = do where verifyNothing t = if t `M.member` o - then fail $ T.unpack t ++ " field found, expected none" + then fail $ show t ++ " field found, expected none" else return () encodeActorLocal :: UriMode u => Authority u -> ActorLocal u -> Series @@ -1421,7 +1421,7 @@ parsePatchLocal o = do where verifyNothing t = if t `M.member` o - then fail $ T.unpack t ++ " field found, expected none" + then fail $ show t ++ " field found, expected none" else return () encodePatchLocal :: UriMode u => Authority u -> PatchLocal -> Series @@ -1490,7 +1490,7 @@ parseBundleLocal o = do where verifyNothing t = if t `M.member` o - then fail $ T.unpack t ++ " field found, expected none" + then fail $ show t ++ " field found, expected none" else return () encodeBundleLocal :: UriMode u => Authority u -> BundleLocal -> Series @@ -1582,7 +1582,7 @@ parseTicketLocal o = do where verifyNothing t = if t `M.member` o - then fail $ T.unpack t ++ " field found, expected none" + then fail $ show t ++ " field found, expected none" else return () encodeTicketLocal :: UriMode u => Authority u -> TicketLocal -> Series @@ -1692,7 +1692,7 @@ instance ActivityPub Ticket where where verifyNothing t = if t `M.member` o - then fail $ T.unpack t ++ " field found, expected none" + then fail $ show t ++ " field found, expected none" else return () toSeries authority diff --git a/src/Web/ActivityPub/Internal.hs b/src/Web/ActivityPub/Internal.hs index d452155..51a9fa7 100644 --- a/src/Web/ActivityPub/Internal.hs +++ b/src/Web/ActivityPub/Internal.hs @@ -143,7 +143,7 @@ import Data.Kind import Data.List import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy -import Data.Semigroup (Endo, First (..)) +import Data.String import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8') import Data.Time.Clock @@ -389,7 +389,7 @@ req :: forall (p::Property) (a::Type) . -> Parser a req obj = obj .: prop where - prop = T.pack $ symbolVal @(PropertySymbol p) Proxy + prop = fromString $ symbolVal @(PropertySymbol p) Proxy opt :: forall (p::Property) (a::Type) . ( FromJSON a @@ -399,7 +399,7 @@ opt :: forall (p::Property) (a::Type) . -> Parser (Maybe a) opt obj = obj .:? prop where - prop = T.pack $ symbolVal @(PropertySymbol p) Proxy + prop = fromString $ symbolVal @(PropertySymbol p) Proxy --instance ToJSONKey Property where -- toJSONKey = toJSONKeyText diff --git a/src/Web/Actor/Deliver.hs b/src/Web/Actor/Deliver.hs index 601e785..7251dcc 100644 --- a/src/Web/Actor/Deliver.hs +++ b/src/Web/Actor/Deliver.hs @@ -25,13 +25,13 @@ module Web.Actor.Deliver ( DeliveryActor , DeliveryStage , DeliveryTheater () - , ActorMessage (..) , startDeliveryTheater + , DeliveryMethod (..) , sendHttp ) where -import Control.Exception.Base +import Control.Exception.Base hiding (handle) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack @@ -41,9 +41,11 @@ import Control.Retry import Data.ByteString (ByteString) import Data.Foldable import Data.Hashable +import Data.HList (HList (..)) import Data.List import Data.List.NonEmpty (NonEmpty) import Data.Maybe +import Data.Proxy import Data.Text (Text) import Data.Time.Clock import Data.Time.Interval @@ -87,15 +89,24 @@ data DeliveryStage u instance UriMode u => Actor (DeliveryActor u) where type ActorStage (DeliveryActor u) = DeliveryStage u type ActorKey (DeliveryActor u) = ObjURI u - type ActorReturn (DeliveryActor _) = () - data ActorMessage (DeliveryActor u) - = MethodDeliverLocal (AP.Envelope u) Bool - | MethodForwardRemote (AP.Errand u) + type ActorInterface (DeliveryActor u) = + [ "deliver-local" ::: AP.Envelope u :-> Bool :-> Return () + , "forward-remote" ::: AP.Errand u :-> Return () + ] instance UriMode u => ActorLaunch (DeliveryActor u) where - actorBehavior uri msg = do - Env _ (manager, headers, micros) <- askEnv - behavior manager headers micros uri msg + actorBehavior _ = + (handleMethod @"deliver-local" := \ uri envelope fwd -> do + Env _ (manager, headers, micros) <- askEnv + behavior manager headers micros uri $ Left (envelope, fwd) + ) + `HCons` + (handleMethod @"forward-remote" := \ uri errand -> do + Env _ (manager, headers, micros) <- askEnv + behavior manager headers micros uri $ Right errand + ) + `HCons` + HNil instance UriMode u => Stage (DeliveryStage u) where data StageEnv (DeliveryStage u) = Env @@ -104,10 +115,6 @@ instance UriMode u => Stage (DeliveryStage u) where } type StageActors (DeliveryStage u) = '[DeliveryActor u] -instance Message (ActorMessage (DeliveryActor u)) where - summarize _ = "Method" - refer _ = "Method" - {- migrations :: [Migration SqlBackend IO] migrations = @@ -143,10 +150,10 @@ behavior -> NonEmpty HeaderName -> Int -> ObjURI u - -> ActorMessage (DeliveryActor u) + -> Either (AP.Envelope u, Bool) (AP.Errand u) -> ActFor (DeliveryStage u) ((), ActFor (DeliveryStage u) (), Next) behavior manager postSignedHeaders micros (ObjURI h lu) = \case - MethodDeliverLocal envelope fwd -> do + Left (envelope, fwd) -> do ra@(RemoteActor mluInbox _mError) <- runBox obtain uInbox <- getInbox let mluFwd = if fwd then Just lu else Nothing @@ -154,7 +161,7 @@ behavior manager postSignedHeaders micros (ObjURI h lu) = \case liftIO $ retry shouldRetry toException $ AP.deliver manager postSignedHeaders envelope mluFwd uInbox done () - MethodForwardRemote errand -> do + Right errand -> do uInbox <- getInbox _resp <- liftIO $ retry shouldRetry toException $ @@ -244,9 +251,24 @@ startDeliveryTheater headers micros manager logFunc dbRootDir = do return (u, env) DeliveryTheater manager headers micros logFunc dbRootDir <$> startTheater logFunc (actors `H.HCons` H.HNil) -sendHttp :: UriMode u => DeliveryTheater u -> ActorMessage (DeliveryActor u) -> [ObjURI u] -> IO () -sendHttp (DeliveryTheater manager headers micros logFunc root theater) method recips = do - for_ recips $ \ u -> - let makeEnv = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (<.> "sqlite3") . (root ) . T.unpack >>= mkEnv (manager, headers, micros) logFunc - in void $ spawnIO theater u makeEnv - sendManyIO theater $ Just (HS.fromList recips, method) `H.HCons` H.HNil +data DeliveryMethod u + = MethodDeliverLocal (AP.Envelope u) Bool + | MethodForwardRemote (AP.Errand u) + +-- Since sendManyIO isn't available right now, we're using many sendIO +sendHttp :: UriMode u => DeliveryTheater u -> DeliveryMethod u -> [ObjURI u] -> IO () +sendHttp (DeliveryTheater manager headers micros logFunc root theater) method recips = + case method of + MethodDeliverLocal envelope fwd -> + for_ recips $ \ u -> do + void $ spawnIO theater u (makeEnv u) + void $ sendIO' @"deliver-local" theater Proxy u $ envelope `HCons` fwd `HCons` HNil + MethodForwardRemote errand -> + for_ recips $ \ u -> do + void $ spawnIO theater u (makeEnv u) + void $ sendIO' @"forward-remote" theater Proxy u $ errand `HCons` HNil + where + makeEnv u = + either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= + encodeUtf . (<.> "sqlite3") . (root ) . T.unpack >>= + mkEnv (manager, headers, micros) logFunc diff --git a/stack.yaml b/stack.yaml index fe7aa69..02cec77 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,7 +3,7 @@ # Specifies the GHC version and set of packages available (e.g., lts-3.5, # nightly-2015-09-21, ghc-7.10.2) -resolver: lts-18.28 +resolver: lts-22.32 # Local packages, usually specified by relative directory name packages: @@ -14,17 +14,15 @@ packages: extra-deps: # yesod-auth-account - git: https://vervis.peers.community/repos/VE2Kr - commit: c2fe99bfe987512b677a32902a4e8b3f3c0009b5 - - git: https://codeberg.org/ForgeFed/darcs-lights - commit: c6005155bcd28f6e4243e8cafed1bd61384cae48 + commit: 0b38f114ebe3ef9b64c7670a3a8497c0857ff2cd - git: https://codeberg.org/ForgeFed/dvara - commit: 2a93bf977b7b1529212999f05525e9158afde7ad + commit: 38525e38c37d1614cbb430ab4439cbbf8f5fdfc0 - git: https://codeberg.org/ForgeFed/haskell-http-signature commit: 0ff017f91169f1d23e78a2edf9ba2e59b227dc86 - git: https://codeberg.org/ForgeFed/haskell-http-client-signature commit: 42b01e0b57c2dcaf78a5dc13c298ec985524d8af - git: https://codeberg.org/ForgeFed/haskell-persistent-migration - commit: 6cfc4292fe78d7be380e2a37751099f55d4cb7b7 + commit: b3114d44d255e3373242c7b9c70ce6203fc0138d - git: https://codeberg.org/ForgeFed/haskell-persistent-email-address commit: ddf0ea55d4e7a0cdf8d57b40f0fc6841de8657af - git: https://codeberg.org/ForgeFed/haskell-time-interval-aeson @@ -33,6 +31,12 @@ extra-deps: commit: 02536f0802120d887ae84bdaeac3e269de82fe2a - git: https://codeberg.org/ForgeFed/haskell-yesod-mail-send commit: ccdc3b453a46d7d3f38998478c421ddc791591ff + - git: https://github.com/TripShot/monadcryptorandom + commit: 05233de8ac31701600a512a67a45b6f3ca382687 + - git: https://codeberg.org/ForgeFed/haskell-cipher-aes128 + commit: 3ecd428b43ceb52e6a73e1ad8eb059d8844abbe9 + - git: https://codeberg.org/ForgeFed/haskell-DRBG + commit: dedfcdd4b95b46a30afe24ba05582995299d38b4 # - git: https://notabug.org/fr33domlover/haskell-persistent # commit: 9cc700b540a680ac1fdc9df94847a631013cb3ca # subdirs: @@ -41,34 +45,14 @@ extra-deps: - ./lib/ssh - - DRBG-0.5.5 - - cipher-aes128-0.7.0.6 + - HList-0.5.3.0 - SimpleAES-0.4.2 - - darcs-2.16.5 - - constraints-0.12 -# - data-default-instances-bytestring-0.0.1 -# - esqueleto-2.7.0 -# - graphviz-2999.20.0.3 + - email-validate-json-0.1.0.0 - highlighter2-0.2.5 - libravatar-0.4.0.2 - - monad-hash-0.1.0.2 - - monadcryptorandom-0.7.2.1 -# - patience-0.3 - - pwstore-fast-2.4.4 -# - sandi-0.5 - - email-validate-json-0.1.0.0 + - smtp-mail-0.4.0.2 - time-interval-0.1.1 -# - time-units-1.0.0 -# - url-2.1.3 - - annotated-exception-0.3.0.1 - - retry-0.9.3.1 -# - base58-bytestring-0.1.0 -# - indexed-profunctors-0.1.1 -# - indexed-traversable-0.1.2.1 -# - optics-core-0.4.1 - - HList-0.5.3.0 -# - first-class-families-0.8.1.0 - - diff-parse-0.2.1 + - vary-0.1.0.3 # Override default flag values for local packages and extra-deps flags: diff --git a/vervis.cabal b/vervis.cabal index 033b9cc..a95dd7c 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -61,7 +61,7 @@ library Crypto.ActorKey Crypto.PubKey.Encoding Crypto.PublicVerifKey - Darcs.Local.Repository + --Darcs.Local.Repository Data.Slab Data.Slab.Backend Data.Slab.Simple @@ -78,7 +78,6 @@ library Data.Either.Local Data.EventTime.Local Data.Functor.Local - Data.Git.Local Data.Graph.DirectedAcyclic.View.Tree Data.Graph.Inductive.Query.Cycle Data.Graph.Inductive.Query.Layer @@ -92,6 +91,7 @@ library Data.List.NonEmpty.Local Data.Maybe.Local Data.MediaType + Data.ObjId Data.Paginate.Local Data.Patch.Local Data.Text.UTF8.Local @@ -111,6 +111,8 @@ library Database.Persist.Local --Database.Persist.Local.Class.PersistEntityHierarchy Database.Persist.Local.RecursionDoc + Development.Darcs + Development.Git Development.PatchMediaType Development.PatchMediaType.JSON Development.PatchMediaType.Persist @@ -350,10 +352,6 @@ library , conduit-extra , containers , cryptonite - -- for Storage.Hashed because hashed-storage seems - -- unmaintained and darcs has its own copy - , darcs - , darcs-lights , data-default , data-default-class , data-default-instances-bytestring @@ -441,8 +439,6 @@ library -- probably should be replaced with lenses once I learn , tuple , typed-process - -- for the actor system Theater actormap - , typerep-map , first-class-families , HList -- For making git hooks executable, i.e. set file mode @@ -451,6 +447,7 @@ library , unliftio-core , unliftio , unordered-containers + , vary , vector , wai , wai-extra @@ -477,7 +474,7 @@ library , zlib hs-source-dirs: src - default-language: Haskell2010 + default-language: GHC2021 if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT @@ -492,7 +489,7 @@ executable vervis main-is: main.hs build-depends: base, vervis hs-source-dirs: app - default-language: Haskell2010 + default-language: GHC2021 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N if flag(library-only) @@ -502,14 +499,14 @@ executable vervis-post-receive main-is: main.hs build-depends: base, vervis hs-source-dirs: hook-git - default-language: Haskell2010 + default-language: GHC2021 ghc-options: -Wall executable vervis-post-apply main-is: main.hs build-depends: base, vervis hs-source-dirs: hook-darcs - default-language: Haskell2010 + default-language: GHC2021 ghc-options: -Wall test-suite test @@ -546,7 +543,7 @@ test-suite test , aeson hs-source-dirs: test - default-language: Haskell2010 + default-language: GHC2021 ghc-options: -Wall type: exitcode-stdio-1.0 @@ -558,6 +555,6 @@ test-suite test -- , hspec -- , vervis -- hs-source-dirs: test --- default-language: Haskell2010 +-- default-language: GHC2021 -- ghc-options: -Wall -- type: exitcode-stdio-1.0