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 :)
2024-08-21 20:17:52 +03:00 · 2024-08-21 20:17:52 +03:00 · e6319aa686
commit e6319aa686
parent 1c993d3397
57 changed files with 2402 additions and 1103 deletions
--- a/src/Control/Concurrent/Actor.hs
+++ b/src/Control/Concurrent/Actor.hs
--- 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
--- 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 <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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)
--- 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 <fr33domlover@riseup.net>.
+ - Written in 2019, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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)

--- 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 <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020, 2024
+ - by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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)
--- a/src/Data/ObjId.hs
+++ b/src/Data/ObjId.hs
@ -0,0 +1,76 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016, 2018, 2019, 2022, 2024
+ - by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module 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
--- 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
--- a/src/Development/Darcs.hs
+++ b/src/Development/Darcs.hs
@ -0,0 +1,411 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016, 2018, 2019, 2022, 2024
+ - by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module 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 <patch>, 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"
--- a/src/Development/Git.hs
+++ b/src/Development/Git.hs
@ -14,7 +14,7 @@
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-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
--- 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"
--- 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
--- 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
 -------------------------------------------------------------------------------
--- 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
--- 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))
--- 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 <fr33domlover@riseup.net>.
 -
 - ♡ 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
--- 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
--- 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
+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 deckBehavior now deckID ve
+            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
--- 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
+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 factoryBehavior now factoryID ve
+            adaptErrbox errboxID False (factoryVerse factoryID) verse
+        )
+        `HCons`
+        (handleMethod @"verified" := \ factoryID personID -> adaptHandlerResult $ do
+            now <- liftIO getCurrentTime
+            factoryCheckPerson now factoryID personID
+        )
+        `HCons`
+        HNil
--- 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
+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 groupBehavior now groupID ve
+            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
--- 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
+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 loomBehavior now loomID ve
+            adaptErrbox errboxID False (loomVerse loomID) verse
+        )
+        `HCons`
+        HNil
--- 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
+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 personBehavior now personID ve
+            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
--- 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
--- 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
+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 projectBehavior now projectID ve
+            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
--- 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
+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 repoBehavior now repoID ve
+            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
--- 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
--- 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

--- 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'
-                -}
-            }
+-- 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
-    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 (== '>')
+    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
--- 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
--- 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 <fr33domlover@riseup.net>.
+ - Written in 2019, 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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
--- 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 <fr33domlover@riseup.net>.
+ - Written in 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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
--- 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
--- 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
--- 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"

--- 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
--- 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 <patch>, 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
--- 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 <fr33domlover@riseup.net>.
+ - Written in 2019, 2024 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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
--- 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) <$>
--- 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")
--- 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)
--- 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)
--- 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)
--- 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)
--- 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)
--- 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)
--- 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)
--- 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 <fr33domlover@riseup.net>.
+ - Written in 2018, 2024 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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"
--- 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,19 +435,16 @@ 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
+    -> (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
--- 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
--- 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
--- 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)
--- 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 []
--- 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)
--- 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
--- 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 
--- 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
+    actorBehavior _ =
+        (handleMethod @"deliver-local" := \ uri envelope fwd -> do
            Env _ (manager, headers, micros) <- askEnv
-        behavior manager headers micros uri msg
+            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
--- 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:
--- 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