Actor system typed methods + upgrade to LTS-22 + remove darcs dep

- I upgraded the actor system (Control.Concurrent.Actor) to support
  typed per-actor methods with type-level names, parameter lists and
  return values
- For extensible sum types, I decided to use the 'vary' package, while
  extensible product still uses 'HList' (other options are to get both
  from 'extensible' (Sum, Prod) or from 'vinyl' (Rec, CoRed))
- Since 'vary' is new, it uses GHC2021 and thus requires GHC 9
- So I decided to make the leap into upgrading to an LTS with GHC 9
- Vervis was at LTS 18, at first I tried 19 and 20 but there were
  dependency version problems, in particular I couldn't solve them for
  the 'darcs' package even when I switched to latest LTS which is 22
- So I decided it's time to do the long-waiting task of switching to
  calling-darcs-process instead of using darcs as a library

All of this together creates a huge commit, but 3 big things are now
solved :)

src/Control/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

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
-    , createRepo
-    , readPristineRoot
     )
 where
 
-import Darcs.Util.Hash
 import Data.Bits
 import Data.Text (Text)
-import System.Directory (createDirectory)
+import System.Directory
-import System.Exit (ExitCode (..))
+import System.Exit
-import System.FilePath ((</>))
+import System.FilePath
-import System.IO (withBinaryFile, IOMode (ReadMode))
 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)

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)
 

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)

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

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

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"

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

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"

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

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.ObjId
-import Data.Git.Local
+import Development.Git
 import Network.Git.Put
 import Network.Git.Types
 
+import Data.Binary.Put.Local
+
 -------------------------------------------------------------------------------
 -- Types
 -------------------------------------------------------------------------------

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

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 <-
+    maybeResult <- liftIO $ callIO' @"client" theater Proxy personID $ msg `HCons` HNil
-        liftIO $ callIO theater personID (PersonMsgClient msg)
+    outboxItemID <-
-    itemText <-
         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
+    return outboxItemID
-        Nothing -> error "read itemText failed"
-        Just outboxItemID -> return outboxItemID
 
 verifyResourceAddressed
     :: (MonadSite m, YesodHashids (SiteEnv m))

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

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
+    , adaptHandlerResult
-    , VervisActor (..)
+    --, VervisActor (..)
-    , VervisActorLaunch (..)
+    --, VervisActorLaunch (..)
-    , ActorMessage (..)
+    --, 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
+    type ActorInterface Person =
-    data ActorMessage Person
+        [ "verse" ::: Verse :-> Ret
-        = PersonMsgVerse Verse
+        , "client" ::: ClientMsg :-> Return (Either Text OutboxItemId)
-        | PersonMsgClient ClientMsg
+        , "init" ::: Ret
-        | PersonMsgInit
+        ]
 instance Actor Deck where
     type ActorStage   Deck = Staje
     type ActorKey     Deck = DeckId
-    type ActorReturn  Deck = Either Text Text
+    type ActorInterface Deck =
-    data ActorMessage Deck
+        [ "verse" ::: Verse :-> Ret
-        = DeckMsgVerse Verse
+        , "init" ::: (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) :-> Ret
-        | DeckMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI))
+        ]
 instance Actor Loom where
     type ActorStage   Loom = Staje
     type ActorKey     Loom = LoomId
-    type ActorReturn  Loom = Either Text Text
+    type ActorInterface Loom =
-    data ActorMessage Loom = MsgL Verse
+        '[ "verse" ::: Verse :-> Ret
+         ]
 instance Actor Repo where
     type ActorStage   Repo = Staje
     type ActorKey     Repo = RepoId
-    type ActorReturn  Repo = Either Text Text
+    type ActorInterface Repo =
-    data ActorMessage Repo = MsgR (Either Verse (IO ()))
+        [ "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
+    type ActorInterface Project =
-    data ActorMessage Project
+        [ "verse" ::: Verse :-> Ret
-        = ProjectMsgVerse Verse
+        , "init" ::: (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) :-> Ret
-        | ProjectMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI))
+        ]
 instance Actor Group where
     type ActorStage   Group = Staje
     type ActorKey     Group = GroupId
-    type ActorReturn  Group = Either Text Text
+    type ActorInterface Group =
-    data ActorMessage Group
+        [ "verse" ::: Verse :-> Ret
-        = TeamMsgVerse Verse
+        , "init" ::: (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) :-> Ret
-        | TeamMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI))
+        ]
 instance Actor Factory where
     type ActorStage   Factory = Staje
     type ActorKey     Factory = FactoryId
-    type ActorReturn  Factory = Either Text Text
+    type ActorInterface Factory =
-    data ActorMessage Factory
+        [ "verse" ::: Verse :-> Ret
-        = FactoryMsgVerse Verse
+        , "verified" ::: PersonId :-> Ret
-        | FactoryMsgVerified PersonId
+        ]
 
+{-
 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
+adaptHandlerResult
-    :: (UTCTime -> ActorKey a -> ActorMessage a -> ExceptT Text Act (Text, Act (), Next))
+    :: ExceptT Text Act (a, Act (), Next)
-    -> (ActorKey a -> ActorMessage a -> Act (Either Text Text, Act (), Next))
+    -> Act (Either Text a, Act (), Next)
-behave handler key msg = do
+adaptHandlerResult handler = do
-    now <- liftIO getCurrentTime
+    result <- runExceptT handler
-    result <- runExceptT $ handler now key msg
     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

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)
+deckVerse :: DeckId -> Verse -> ActE (Text, Act (), Next)
-deckBehavior now deckID (DeckMsgVerse verse@(Verse _authorIdMsig body)) =
+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
+instance ActorLaunch Deck where
-    actorBehavior' now deckID ve = do
+    actorBehavior _ =
-        errboxID <- lift $ withDB $ do
+        (handleMethod @"verse" := \ deckID verse -> adaptHandlerResult $ do
-            resourceID <- deckResource <$> getJust deckID
+            errboxID <- lift $ withDB $ do
-            Resource actorID <- getJust resourceID
+                resourceID <- deckResource <$> getJust deckID
-            actorErrbox <$> getJust actorID
+                Resource actorID <- getJust resourceID
-        adaptErrbox errboxID False deckBehavior now deckID ve
+                actorErrbox <$> getJust actorID
+            adaptErrbox errboxID False (deckVerse deckID) verse
+        )
+        `HCons`
+        (handleMethod @"init" := \ deckID creator -> adaptHandlerResult $ do
+            now <- liftIO getCurrentTime
+            let grabResource = fmap komponentResource . getJust . deckKomponent
+            topicInit grabResource LocalResourceDeck now deckID creator
+        )
+        `HCons`
+        HNil

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)
+factoryVerse :: FactoryId -> Verse -> ActE (Text, Act (), Next)
-factoryBehavior now factoryID (FactoryMsgVerse verse@(Verse _authorIdMsig body)) =
+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
+instance ActorLaunch Factory where
-    actorBehavior' now factoryID ve = do
+    actorBehavior _ =
-        errboxID <- lift $ withDB $ do
+        (handleMethod @"verse" := \ factoryID verse -> adaptHandlerResult $ do
-            resourceID <- factoryResource <$> getJust factoryID
+            errboxID <- lift $ withDB $ do
-            Resource actorID <- getJust resourceID
+                resourceID <- factoryResource <$> getJust factoryID
-            actorErrbox <$> getJust actorID
+                Resource actorID <- getJust resourceID
-        adaptErrbox errboxID False factoryBehavior now factoryID ve
+                actorErrbox <$> getJust actorID
+            adaptErrbox errboxID False (factoryVerse factoryID) verse
+        )
+        `HCons`
+        (handleMethod @"verified" := \ factoryID personID -> adaptHandlerResult $ do
+            now <- liftIO getCurrentTime
+            factoryCheckPerson now factoryID personID
+        )
+        `HCons`
+        HNil

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)
+groupVerse :: GroupId -> Verse -> ActE (Text, Act (), Next)
-groupBehavior now groupID (TeamMsgVerse verse@(Verse _authorIdMsig body)) =
+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
+instance ActorLaunch Group where
-    actorBehavior' now groupID ve = do
+    actorBehavior _ =
-        errboxID <- lift $ withDB $ do
+        (handleMethod @"verse" := \ groupID verse -> adaptHandlerResult $ do
-            resourceID <- groupResource <$> getJust groupID
+            errboxID <- lift $ withDB $ do
-            Resource actorID <- getJust resourceID
+                resourceID <- groupResource <$> getJust groupID
-            actorErrbox <$> getJust actorID
+                Resource actorID <- getJust resourceID
-        adaptErrbox errboxID False groupBehavior now groupID ve
+                actorErrbox <$> getJust actorID
+            adaptErrbox errboxID False (groupVerse groupID) verse
+        )
+        `HCons`
+        (handleMethod @"init" := \ groupID creator -> adaptHandlerResult $ do
+            now <- liftIO getCurrentTime
+            let grabResource = pure . groupResource
+            topicInit grabResource LocalResourceGroup now groupID creator
+        )
+        `HCons`
+        HNil

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)
+loomVerse :: LoomId -> Verse -> ActE (Text, Act (), Next)
-loomBehavior now loomID (MsgL verse@(Verse _authorIdMsig body)) =
+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
+instance ActorLaunch Loom where
-    actorBehavior' now loomID ve = do
+    actorBehavior _ =
-        errboxID <- lift $ withDB $ do
+        (handleMethod @"verse" := \ loomID verse -> adaptHandlerResult $ do
-            resourceID <- loomResource <$> getJust loomID
+            errboxID <- lift $ withDB $ do
-            Resource actorID <- getJust resourceID
+                resourceID <- loomResource <$> getJust loomID
-            actorErrbox <$> getJust actorID
+                Resource actorID <- getJust resourceID
-        adaptErrbox errboxID False loomBehavior now loomID ve
+                actorErrbox <$> getJust actorID
+            adaptErrbox errboxID False (loomVerse loomID) verse
+        )
+        `HCons`
+        HNil

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)
+personVerse personID verse@(Verse _authorIdMsig body) = do
-personBehavior now personID (PersonMsgVerse verse@(Verse _authorIdMsig body)) =
+    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
+instance ActorLaunch Person where
-    actorBehavior' now personID ve = do
+    actorBehavior _ =
-        errboxID <- lift $ withDB $ do
+        (handleMethod @"verse" := \ personID verse -> adaptHandlerResult $ do
-            actorID <- personActor <$> getJust personID
+            errboxID <- lift $ withDB $ do
-            actorErrbox <$> getJust actorID
+                actorID <- personActor <$> getJust personID
-        adaptErrbox errboxID True personBehavior now personID ve
+                actorErrbox <$> getJust actorID
+            adaptErrbox errboxID True (personVerse personID) verse
+        )
+        `HCons`
+        (handleMethod @"client" := \ personID msg -> adaptHandlerResult $ do
+            now <- liftIO getCurrentTime
+            clientBehavior now personID msg
+        )
+        `HCons`
+        (handleMethod @"init" := \ personID -> adaptHandlerResult $ do
+            now <- liftIO getCurrentTime
+            personInit now personID
+        )
+        `HCons`
+        HNil

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

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)
+projectVerse :: ProjectId -> Verse -> ActE (Text, Act (), Next)
-projectBehavior now projectID (ProjectMsgVerse verse@(Verse _authorIdMsig body)) =
+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
+instance ActorLaunch Project where
-    actorBehavior' now projectID ve = do
+    actorBehavior _ =
-        errboxID <- lift $ withDB $ do
+        (handleMethod @"verse" := \ projectID verse -> adaptHandlerResult $ do
-            resourceID <- projectResource <$> getJust projectID
+            errboxID <- lift $ withDB $ do
-            Resource actorID <- getJust resourceID
+                resourceID <- projectResource <$> getJust projectID
-            actorErrbox <$> getJust actorID
+                Resource actorID <- getJust resourceID
-        adaptErrbox errboxID False projectBehavior now projectID ve
+                actorErrbox <$> getJust actorID
+            adaptErrbox errboxID False (projectVerse projectID) verse
+        )
+        `HCons`
+        (handleMethod @"init" := \ projectID creator -> adaptHandlerResult $ do
+            now <- liftIO getCurrentTime
+            let grabResource = pure . projectResource
+            topicInit grabResource LocalResourceProject now projectID creator
+        )
+        `HCons`
+        HNil

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)
+repoVerse :: RepoId -> Verse -> ActE (Text, Act (), Next)
-repoBehavior now repoID (MsgR (Left _verse@(Verse _authorIdMsig body))) =
+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
+instance ActorLaunch Repo where
-    actorBehavior' now repoID ve = do
+    actorBehavior _ =
-        errboxID <- lift $ withDB $ do
+        (handleMethod @"verse" := \ repoID verse -> adaptHandlerResult $ do
-            resourceID <- repoResource <$> getJust repoID
+            errboxID <- lift $ withDB $ do
-            Resource actorID <- getJust resourceID
+                resourceID <- repoResource <$> getJust repoID
-            actorErrbox <$> getJust actorID
+                Resource actorID <- getJust resourceID
-        adaptErrbox errboxID False repoBehavior now repoID ve
+                actorErrbox <$> getJust actorID
+            adaptErrbox errboxID False (repoVerse repoID) verse
+        )
+        `HCons`
+        (handleMethod @"wait-during-push" := \ repoID waitValue -> adaptHandlerResult $ do
+            liftIO waitValue
+            done "Waited for push to complete"
+        )
+        `HCons`
+        HNil

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

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
 

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
+findReadme :: Text -> FilePath -> DirTree -> DarcsT IO (Maybe (Text, Text))
-dirToAnchoredPath = AnchoredPath . map (decodeWhiteName . encodeUtf8)
+findReadme patch dirPath (DirTree _ files) =
-
+    for (F.find (isReadme . T.pack) files) $ \ name -> do
-matchType :: ItemType -> EntryType
+        body <- darcsGetFileContent patch $ dirPath </> name
-matchType TreeType = TypeTree
+        return (T.pack name, body)
-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)
 
 readSourceView
-    :: FilePath
+    :: [EntryName]
-    -- ^ Repository path
-    -> [EntryName]
     -- ^ Path in the source tree pointing to a file or directory
-    -> IO (Maybe (SourceView Widget))
+    -> DarcsT IO (Maybe (SourceView Widget))
-readSourceView path dir = do
+readSourceView dir = do
-    stubbedTree <- readStubbedTree path
+    let invalid t = T.null t || t == "." || t == ".." || T.any (== '/') t
-    msv <- if null dir
+    when (any invalid dir) $
-        then do
+        error $ "readSourceView invalid dir: " ++ show dir
-            let items = listImmediate stubbedTree
+    hash <- darcsGetHead
-            mreadme <- findReadme items
+    top <- darcsGetTree hash
-            return $ Just $ SourceDir DirectoryView
+    msv <- for (lookupTreeItem (map T.unpack dir) top) $ \case
-                { dvName    = Nothing
+        Left () -> do
-                , dvEntries = map (uncurry itemToEntry) items
+            let dir' = T.unpack $ T.intercalate "/" dir
-                , dvReadme  = mreadme
+            body <- darcsGetFileContent hash dir'
-                }
+            return $ SourceFile $ FileView (last dir) body
-        else do
+        Right tree@(DirTree subdirs files) -> do
-            let anch = dirToAnchoredPath dir
+            let dir' = T.unpack $ T.intercalate "/" dir
-            expandedTree <- expandPath stubbedTree anch
+            mreadme <- findReadme hash dir' tree
-            let mitem = find expandedTree anch
+            let mname =
-            for mitem $ itemToSourceView (last dir)
+                    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
+    :: MonadIO m
-    -- ^ Repository path
+    => Int
-    -> 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
+readChangesView off lim = fmap maybeRight $ runExceptT $ lift $ do
-    total <- ExceptT $ readLatestInventory path latestInventorySizeP
+    cs <- darcsLog (Just lim) (Just off)
-    let off' = total - off - lim
+    total <- darcsLogLength
-    ps <- ExceptT $ readLatestInventory path $ latestInventoryPageP off' lim
+    now <- liftIO getCurrentTime
-    now <- lift getCurrentTime
+    let toLE c = LogEntry
-    let toLE (pi, h, _) = LogEntry
+            { leAuthor  = VC.authorName $ fst $ VC.commitWritten c
-            { leAuthor  =
+            , leHash    = VC.commitHash c
-                T.stripEnd $ T.takeWhile (/= '<') $ piAuthor pi
+            , leMessage = VC.commitTitle c
-            , leHash    = decodeStrict $ encodePatchInfoHash h
-            , leMessage = piTitle pi
             , 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
+-- Copied from Vervis.Git, perhaps move to a common module?
--- repository. Preconditions:
+patch :: Text -> VC.Commit -> P.Patch
---
+patch edits (VC.Commit a c _ t d) = P.Patch (mk a) (mk <$> c) t d edits
--- * The repo's existence has been verified against the DB
+    where
--- * The repo dir is assumed to exist. If it doesn't, an exception is thrown.
+    mk = first mk'
--- * The repository is assumed to be in a consistent state, all the expected
+    mk' (VC.Author n e) = P.Author n e
---   inventory files and patch files and so on are assumed to exist and have
+
---   the expected format. If not, an exception is thrown.
+readPatch :: ObjId -> MonadIO m => DarcsT m P.Patch
--- * The hash may or may not be found in the repo. If there's no patch in the
+readPatch oid = do
---   repo with the given hash, 'Nothing' is returned.
+    commit <- darcsShowCommit oid
-readPatch :: FilePath -> Text -> IO (Maybe DP.Patch)
+    deltas <- darcsDiff oid
-readPatch path hash = handle $ runExceptT $ do
+    return $ patch deltas commit
-    pih <- except $ second PatchInfoHash $ B16.decode $ encodeUtf8 hash
-    li <- ExceptT $ readLatestInventory path latestInventoryAllP
-    mp <- loop pih (liPatches li) (fst <$> liPrevTag li)
-    for mp $ \ (pi, pch) -> do
-        changes <-
-            ExceptT $ readCompressedPatch path pch AB.takeByteString -- (P.patch <* A.endOfInput)
-        changes' <- either (throwE . displayException) return $ TE.decodeUtf8' changes
-        (an, ae) <-
-            ExceptT . pure $ A.parseOnly (author <* A.endOfInput) $ piAuthor pi
-        return DP.Patch
-            { patchWritten     =
-                ( Author
-                    { authorName  = an
-                    , authorEmail = ae
-                    }
-                , piTime pi
-                )
-            , patchCommitted   = Nothing
-            , patchTitle       = piTitle pi
-            , patchDescription = fromMaybe "" $ piDescription pi
-            , patchDiff        = changes'
-                {-
-                let (befores, pairs, afters) = groupEithers $ map splitChange changes
-                    befores' = mkedit befores
-                    pairs' = map (bimap arrangeHunks mkedit) pairs
-                    afters' = arrangeHunks <$> nonEmpty afters
-                in  befores' ++ concatMap (NE.toList . uncurry (<>)) pairs' ++ maybe [] NE.toList afters'
-                -}
-            }
-  where
-    handle a = do
-        r <- a
-        case r of
-            Left e -> fail $ "readPatch failed: " ++ e
-            Right mp -> return mp
-    lookup' pih ps = case F.find (\ (_pi, pih', _pch) -> pih' == pih) ps of
-        Nothing              -> Nothing
-        Just (pi, _pih, pch) -> Just (pi, pch)
-    loop pih ps mih = case lookup' pih ps of
-        Just p  -> return $ Just p
-        Nothing -> case mih of
-            Nothing -> return Nothing
-            Just ih -> do
-                i <- ExceptT $ readCompressedInventory path ih earlyInventoryAllP
-                case i of
-                    Left ei  -> loop pih (eiPatches ei) Nothing
-                    Right mi -> loop pih (miPatches mi) (Just $ miPrevious mi)
-    email = maybe (fail "invalid email") pure . emailAddress . encodeUtf8
-    author = (,)
-        <$> (T.stripEnd <$> A.takeWhile1 (/= '<'))
-        <*  A.skip (== '<')
-        <*> (A.takeWhile1 (/= '>') >>= email)
-        <*  A.skip (== '>')
 
 writePostApplyHooks :: WorkerDB ()
 writePostApplyHooks = do

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

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

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

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

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

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"
 

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 Development.Git as G (createRepo)
-import qualified Darcs.Local.Repository as D (createRepo)
+import qualified Development.Darcs as D (createRepo)
 
 import Vervis.Access
 import Vervis.ActivityPub

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

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.Schema ()
-import Database.Persist.Sql (SqlBackend, ConnectionPool, runSqlPool)
+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

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 Run m = SchemaT m ()
-type Mig m = Migration SqlBackend 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) <$>

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.Types
-import Database.Persist.Schema.SQL ()
+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 :: [Entity]
-model_2016_08_04 = $(schema "2016_08_04")
+model_2016_08_04 = $$(schema "2016_08_04")
 
-model_2016_09_01_just_workflow :: [Entity SqlBackend]
+model_2016_09_01_just_workflow :: [Entity]
-model_2016_09_01_just_workflow = $(schema "2016_09_01_just_workflow")
+model_2016_09_01_just_workflow = $$(schema "2016_09_01_just_workflow")
 
-model_2016_09_01_rest :: [Entity SqlBackend]
+model_2016_09_01_rest :: [Entity]
-model_2016_09_01_rest = $(schema "2016_09_01_rest")
+model_2016_09_01_rest = $$(schema "2016_09_01_rest")
 
-model_2019_02_03_verifkey :: [Entity SqlBackend]
+model_2019_02_03_verifkey :: [Entity]
-model_2019_02_03_verifkey = $(schema "2019_02_03_verifkey")
+model_2019_02_03_verifkey = $$(schema "2019_02_03_verifkey")
 
-model_2019_03_19 :: [Entity SqlBackend]
+model_2019_03_19 :: [Entity]
-model_2019_03_19 = $(schema "2019_03_19")
+model_2019_03_19 = $$(schema "2019_03_19")
 
-model_2019_03_30 :: [Entity SqlBackend]
+model_2019_03_30 :: [Entity]
-model_2019_03_30 = $(schema "2019_03_30")
+model_2019_03_30 = $$(schema "2019_03_30")
 
-model_2019_04_11 :: [Entity SqlBackend]
+model_2019_04_11 :: [Entity]
-model_2019_04_11 = $(schema "2019_04_11")
+model_2019_04_11 = $$(schema "2019_04_11")
 
-model_2019_04_12 :: [Entity SqlBackend]
+model_2019_04_12 :: [Entity]
-model_2019_04_12 = $(schema "2019_04_12")
+model_2019_04_12 = $$(schema "2019_04_12")
 
-model_2019_04_22 :: [Entity SqlBackend]
+model_2019_04_22 :: [Entity]
-model_2019_04_22 = $(schema "2019_04_22")
+model_2019_04_22 = $$(schema "2019_04_22")
 
-model_2019_05_03 :: [Entity SqlBackend]
+model_2019_05_03 :: [Entity]
-model_2019_05_03 = $(schema "2019_05_03")
+model_2019_05_03 = $$(schema "2019_05_03")
 
-model_2019_05_17 :: [Entity SqlBackend]
+model_2019_05_17 :: [Entity]
-model_2019_05_17 = $(schema "2019_05_17")
+model_2019_05_17 = $$(schema "2019_05_17")
 
-model_2019_06_06 :: [Entity SqlBackend]
+model_2019_06_06 :: [Entity]
-model_2019_06_06 = $(schema "2019_06_06")
+model_2019_06_06 = $$(schema "2019_06_06")
 
-model_2019_09_25 :: [Entity SqlBackend]
+model_2019_09_25 :: [Entity]
-model_2019_09_25 = $(schema "2019_09_25")
+model_2019_09_25 = $$(schema "2019_09_25")
 
-model_2019_11_04 :: [Entity SqlBackend]
+model_2019_11_04 :: [Entity]
-model_2019_11_04 = $(schema "2019_11_04")
+model_2019_11_04 = $$(schema "2019_11_04")
 
-model_2020_01_05 :: [Entity SqlBackend]
+model_2020_01_05 :: [Entity]
-model_2020_01_05 = $(schema "2020_01_05")
+model_2020_01_05 = $$(schema "2020_01_05")
 
-model_2020_02_05 :: [Entity SqlBackend]
+model_2020_02_05 :: [Entity]
-model_2020_02_05 = $(schema "2020_02_05_local_ticket")
+model_2020_02_05 = $$(schema "2020_02_05_local_ticket")
 
-model_2020_02_07 :: [Entity SqlBackend]
+model_2020_02_07 :: [Entity]
-model_2020_02_07 = $(schema "2020_02_07_tpl")
+model_2020_02_07 = $$(schema "2020_02_07_tpl")
 
-model_2020_02_09 :: [Entity SqlBackend]
+model_2020_02_09 :: [Entity]
-model_2020_02_09 = $(schema "2020_02_09_tup")
+model_2020_02_09 = $$(schema "2020_02_09_tup")
 
-model_2020_02_22 :: [Entity SqlBackend]
+model_2020_02_22 :: [Entity]
-model_2020_02_22 = $(schema "2020_02_22_tpr")
+model_2020_02_22 = $$(schema "2020_02_22_tpr")
 
-model_2020_04_07 :: [Entity SqlBackend]
+model_2020_04_07 :: [Entity]
-model_2020_04_07 = $(schema "2020_04_07_tpra")
+model_2020_04_07 = $$(schema "2020_04_07_tpra")
 
-model_2020_04_09 :: [Entity SqlBackend]
+model_2020_04_09 :: [Entity]
-model_2020_04_09 = $(schema "2020_04_09_rt")
+model_2020_04_09 = $$(schema "2020_04_09_rt")
 
-model_2020_05_12 :: [Entity SqlBackend]
+model_2020_05_12 :: [Entity]
-model_2020_05_12 = $(schema "2020_05_12_fwd_sender")
+model_2020_05_12 = $$(schema "2020_05_12_fwd_sender")
 
-model_2020_05_16 :: [Entity SqlBackend]
+model_2020_05_16 :: [Entity]
-model_2020_05_16 = $(schema "2020_05_16_tcl")
+model_2020_05_16 = $$(schema "2020_05_16_tcl")
 
-model_2020_05_17 :: [Entity SqlBackend]
+model_2020_05_17 :: [Entity]
-model_2020_05_17 = $(schema "2020_05_17_patch")
+model_2020_05_17 = $$(schema "2020_05_17_patch")
 
-model_2020_05_25 :: [Entity SqlBackend]
+model_2020_05_25 :: [Entity]
-model_2020_05_25 = $(schema "2020_05_25_fwd_sender_repo")
+model_2020_05_25 = $$(schema "2020_05_25_fwd_sender_repo")
 
-model_2020_05_28 :: [Entity SqlBackend]
+model_2020_05_28 :: [Entity]
-model_2020_05_28 = $(schema "2020_05_28_tda")
+model_2020_05_28 = $$(schema "2020_05_28_tda")
 
-model_2020_06_01 :: [Entity SqlBackend]
+model_2020_06_01 :: [Entity]
-model_2020_06_01 = $(schema "2020_06_01_tdc")
+model_2020_06_01 = $$(schema "2020_06_01_tdc")
 
-model_2020_06_18 :: [Entity SqlBackend]
+model_2020_06_18 :: [Entity]
-model_2020_06_18 = $(schema "2020_06_18_tdo")
+model_2020_06_18 = $$(schema "2020_06_18_tdo")
 
-model_2020_07_23 :: [Entity SqlBackend]
+model_2020_07_23 :: [Entity]
-model_2020_07_23 = $(schema "2020_07_23_remote_collection_reboot")
+model_2020_07_23 = $$(schema "2020_07_23_remote_collection_reboot")
 
-model_2020_07_27 :: [Entity SqlBackend]
+model_2020_07_27 :: [Entity]
-model_2020_07_27 = $(schema "2020_07_27_ticket_resolve")
+model_2020_07_27 = $$(schema "2020_07_27_ticket_resolve")
 
-model_2020_08_10 :: [Entity SqlBackend]
+model_2020_08_10 :: [Entity]
-model_2020_08_10 = $(schema "2020_08_10_bundle")
+model_2020_08_10 = $$(schema "2020_08_10_bundle")
 
-model_2022_06_14 :: [Entity SqlBackend]
+model_2022_06_14 :: [Entity]
-model_2022_06_14 = $(schema "2022_06_14_collab")
+model_2022_06_14 = $$(schema "2022_06_14_collab")
 
-model_2022_07_17 :: [Entity SqlBackend]
+model_2022_07_17 :: [Entity]
-model_2022_07_17 = $(schema "2022_07_17_actor")
+model_2022_07_17 = $$(schema "2022_07_17_actor")
 
-model_2022_07_24 :: [Entity SqlBackend]
+model_2022_07_24 :: [Entity]
-model_2022_07_24 = $(schema "2022_07_24_collab_fulfills")
+model_2022_07_24 = $$(schema "2022_07_24_collab_fulfills")
 
-model_384_loom :: [Entity SqlBackend]
+model_384_loom :: [Entity]
-model_384_loom = $(schema "384_2022-08-04_loom")
+model_384_loom = $$(schema "384_2022-08-04_loom")
 
-model_386_assignee :: [Entity SqlBackend]
+model_386_assignee :: [Entity]
-model_386_assignee = $(schema "386_2022-08-04_assignee")
+model_386_assignee = $$(schema "386_2022-08-04_assignee")
 
-model_399_fwder :: [Entity SqlBackend]
+model_399_fwder :: [Entity]
-model_399_fwder = $(schema "399_2022-08-04_fwder")
+model_399_fwder = $$(schema "399_2022-08-04_fwder")
 
-model_408_collab_loom :: [Entity SqlBackend]
+model_408_collab_loom :: [Entity]
-model_408_collab_loom = $(schema "408_2022-08-04_collab_loom")
+model_408_collab_loom = $$(schema "408_2022-08-04_collab_loom")
 
-model_425_collab_accept :: [Entity SqlBackend]
+model_425_collab_accept :: [Entity]
-model_425_collab_accept = $(schema "425_2022-08-21_collab_accept")
+model_425_collab_accept = $$(schema "425_2022-08-21_collab_accept")
 
-model_428_collab_topic_local :: [Entity SqlBackend]
+model_428_collab_topic_local :: [Entity]
-model_428_collab_topic_local = $(schema "428_2022-08-29_collab_topic_local")
+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 :: [Entity]
-model_451_collab_remote_accept = $(schema "451_2022-08-30_collab_remote_accept")
+model_451_collab_remote_accept = $$(schema "451_2022-08-30_collab_remote_accept")
 
-model_453_collab_receive :: [Entity SqlBackend]
+model_453_collab_receive :: [Entity]
-model_453_collab_receive = $(schema "453_2022-09-01_collab_receive")
+model_453_collab_receive = $$(schema "453_2022-09-01_collab_receive")
 
-model_494_mr_origin :: [Entity SqlBackend]
+model_494_mr_origin :: [Entity]
-model_494_mr_origin = $(schema "494_2022-09-17_mr_origin")
+model_494_mr_origin = $$(schema "494_2022-09-17_mr_origin")
 
-model_497_sigkey :: [Entity SqlBackend]
+model_497_sigkey :: [Entity]
-model_497_sigkey = $(schema "497_2022-09-29_sigkey")
+model_497_sigkey = $$(schema "497_2022-09-29_sigkey")
 
-model_508_invite :: [Entity SqlBackend]
+model_508_invite :: [Entity]
-model_508_invite = $(schema "508_2022-10-19_invite")
+model_508_invite = $$(schema "508_2022-10-19_invite")
 
-model_530_join :: [Entity SqlBackend]
+model_530_join :: [Entity]
-model_530_join = $(schema "530_2022-11-01_join")
+model_530_join = $$(schema "530_2022-11-01_join")
 
-model_531_follow_request :: [Entity SqlBackend]
+model_531_follow_request :: [Entity]
-model_531_follow_request = $(schema "531_2023-06-15_follow_request")
+model_531_follow_request = $$(schema "531_2023-06-15_follow_request")
 
-model_541_project :: [Entity SqlBackend]
+model_541_project :: [Entity]
-model_541_project = $(schema "541_2023-06-26_project")
+model_541_project = $$(schema "541_2023-06-26_project")
 
-model_542_component :: [Entity SqlBackend]
+model_542_component :: [Entity]
-model_542_component = $(schema "542_2023-06-26_component")
+model_542_component = $$(schema "542_2023-06-26_component")
 
-model_551_group_collab :: [Entity SqlBackend]
+model_551_group_collab :: [Entity]
-model_551_group_collab = $(schema "551_2023-11-21_group_collab")
+model_551_group_collab = $$(schema "551_2023-11-21_group_collab")
 
-model_552_collab_deleg :: [Entity SqlBackend]
+model_552_collab_deleg :: [Entity]
-model_552_collab_deleg = $(schema "552_2023-11-21_collab_deleg")
+model_552_collab_deleg = $$(schema "552_2023-11-21_collab_deleg")
 
-model_564_permit :: [Entity SqlBackend]
+model_564_permit :: [Entity]
-model_564_permit = $(schema "564_2023-11-22_permit")
+model_564_permit = $$(schema "564_2023-11-22_permit")
 
-model_570_source_dest :: [Entity SqlBackend]
+model_570_source_dest :: [Entity]
-model_570_source_dest = $(schema "570_2023-12-09_source_dest")
+model_570_source_dest = $$(schema "570_2023-12-09_source_dest")
 
-model_577_component_gather :: [Entity SqlBackend]
+model_577_component_gather :: [Entity]
-model_577_component_gather = $(schema "577_2024-03-13_component_gather")
+model_577_component_gather = $$(schema "577_2024-03-13_component_gather")
 
-model_578_source_remove :: [Entity SqlBackend]
+model_578_source_remove :: [Entity]
-model_578_source_remove = $(schema "578_2024-04-03_source_remove")
+model_578_source_remove = $$(schema "578_2024-04-03_source_remove")
 
-model_583_dest_start :: [Entity SqlBackend]
+model_583_dest_start :: [Entity]
-model_583_dest_start = $(schema "583_2024-04-13_dest_start")
+model_583_dest_start = $$(schema "583_2024-04-13_dest_start")
 
-model_591_component_gather :: [Entity SqlBackend]
+model_591_component_gather :: [Entity]
-model_591_component_gather = $(schema "591_2024-04-14_component_gather")
+model_591_component_gather = $$(schema "591_2024-04-14_component_gather")
 
-model_592_permit_extend :: [Entity SqlBackend]
+model_592_permit_extend :: [Entity]
-model_592_permit_extend = $(schema "592_2024-04-18_permit_extend")
+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 :: [Entity]
-model_603_resource = $(schema "603_2024-04-20_resource")
+model_603_resource = $$(schema "603_2024-04-20_resource")
 
-model_626_komponent :: [Entity SqlBackend]
+model_626_komponent :: [Entity]
-model_626_komponent = $(schema "626_2024-04-29_komponent")
+model_626_komponent = $$(schema "626_2024-04-29_komponent")
 
-model_638_effort_squad :: [Entity SqlBackend]
+model_638_effort_squad :: [Entity]
-model_638_effort_squad = $(schema "638_2024-05-14_effort_squad")
+model_638_effort_squad = $$(schema "638_2024-05-14_effort_squad")
 
-model_639_component_convey :: [Entity SqlBackend]
+model_639_component_convey :: [Entity]
-model_639_component_convey = $(schema "639_2024-05-14_component_convey")
+model_639_component_convey = $$(schema "639_2024-05-14_component_convey")
 
 type ListOfByteStrings = [ByteString]
 
-model_648_report :: [Entity SqlBackend]
+model_648_report :: [Entity]
-model_648_report = $(schema "648_2024-07-06_report")
+model_648_report = $$(schema "648_2024-07-06_report")
 
-model_649_factory :: [Entity SqlBackend]
+model_649_factory :: [Entity]
-model_649_factory = $(schema "649_2024-07-29_factory")
+model_649_factory = $$(schema "649_2024-07-29_factory")
 
-model_650_fulfills_resident :: [Entity SqlBackend]
+model_650_fulfills_resident :: [Entity]
-model_650_fulfills_resident = $(schema "650_2024-08-03_fulfills_resident")
+model_650_fulfills_resident = $$(schema "650_2024-08-03_fulfills_resident")

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)

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)

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)

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)

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)

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)

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)

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 Database.Persist.Schema.TH
-import Language.Haskell.TH (Q, Exp)
+import Database.Persist.Schema.Types
-import System.FilePath ((</>), (<.>))
+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"

src/Vervis/Persist/Actor.hs

@@ -58,7 +58,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
-import Data.Aeson
+import Data.Aeson hiding (Key)
 import Data.Barbie
 import Data.ByteString (ByteString)
 import Data.Bitraversable
@@ -89,6 +89,7 @@ import Control.Monad.Trans.Except.Local
 import Data.Maybe.Local
 import Database.Persist.Local
 
+import Vervis.Actor (Verse)
 import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.FedURI
@@ -434,24 +435,21 @@ insertToInbox now (Right (author, luAct, _)) body inboxID unread = do
         Just _ -> return $ Just (ibiid, Right (author, luAct, ractid))
 
 adaptErrbox
-    :: VA.VervisActor a
+    :: InboxId
-    => InboxId
     -> Bool
-    -> (UTCTime -> ActorKey a -> ActorMessage a -> VA.ActE (Text, VA.Act (), Next))
+    -> (Verse -> VA.ActE (Text, VA.Act (), Next))
-    -> UTCTime -> ActorKey a -> ActorMessage a -> VA.ActE (Text, VA.Act (), Next)
+    -> Verse -> VA.ActE (Text, VA.Act (), Next)
-adaptErrbox inboxID unread behavior now key msg =
+adaptErrbox inboxID unread behavior verse@(VA.Verse authorIdMsig body) = do
-    case VA.toVerse msg of
+    result <- lift $ runExceptT $ behavior verse
-        Nothing -> behavior now key msg
+    case result of
-        Just (VA.Verse authorIdMsig body) -> do
+        Right success -> return success
-            result <- lift $ runExceptT $ behavior now key msg
+        Left err -> do
-            case result of
+            now <- liftIO getCurrentTime
-                Right success -> return success
+            _ <- lift $ VA.withDB $ runMaybeT $ do
-                Left err -> do
+                _ <- MaybeT $ get inboxID
-                    _ <- lift $ VA.withDB $ runMaybeT $ do
+                (itemID, _) <- MaybeT $ insertToInbox now authorIdMsig body inboxID unread
-                        _ <- MaybeT $ get inboxID
+                lift $ update itemID [InboxItemResult =. err]
-                        (itemID, _) <- MaybeT $ insertToInbox now authorIdMsig body inboxID unread
+            throwE err
-                        lift $ update itemID [InboxItemResult =. err]
-                    throwE err
 
 getActivityIdent
     :: MonadIO m

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

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

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)

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
+    patch <- liftIO $ do
-    case mpatch of
+        oid <- parseObjId ref
-        Nothing -> notFound
+        withDarcsRepo path $ D.readPatch oid
-        Just patch -> serveCommit hash ref patch []
+    serveCommit hash ref patch []

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)

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

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 

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 _) = ()
+    type ActorInterface (DeliveryActor u) =
-    data ActorMessage (DeliveryActor u)
+        [ "deliver-local" ::: AP.Envelope u :-> Bool :-> Return ()
-        = MethodDeliverLocal (AP.Envelope u) Bool
+        , "forward-remote" ::: AP.Errand u :-> Return ()
-        | MethodForwardRemote (AP.Errand u)
+        ]
 
 instance UriMode u => ActorLaunch (DeliveryActor u) where
-    actorBehavior uri msg = do
+    actorBehavior _ =
-        Env _ (manager, headers, micros) <- askEnv
+        (handleMethod @"deliver-local" := \ uri envelope fwd -> do
-        behavior manager headers micros uri msg
+            Env _ (manager, headers, micros) <- askEnv
+            behavior manager headers micros uri $ Left (envelope, fwd)
+        )
+        `HCons`
+        (handleMethod @"forward-remote" := \ uri errand -> do
+            Env _ (manager, headers, micros) <- askEnv
+            behavior manager headers micros uri $ Right errand
+        )
+        `HCons`
+        HNil
 
 instance UriMode u => Stage (DeliveryStage u) where
     data StageEnv (DeliveryStage u) = Env
@@ -104,10 +115,6 @@ instance UriMode u => Stage (DeliveryStage u) where
         }
     type StageActors (DeliveryStage u) = '[DeliveryActor u]
 
-instance Message (ActorMessage (DeliveryActor u)) where
-    summarize _ = "Method"
-    refer _     = "Method"
-
 {-
 migrations :: [Migration SqlBackend IO]
 migrations =
@@ -143,10 +150,10 @@ behavior
     -> NonEmpty HeaderName
     -> Int
     -> ObjURI u
-    -> ActorMessage (DeliveryActor u)
+    -> Either (AP.Envelope u, Bool) (AP.Errand u)
     -> ActFor (DeliveryStage u) ((), ActFor (DeliveryStage u) (), Next)
 behavior manager postSignedHeaders micros (ObjURI h lu) = \case
-    MethodDeliverLocal envelope fwd -> do
+    Left (envelope, fwd) -> do
         ra@(RemoteActor mluInbox _mError) <- runBox obtain
         uInbox <- getInbox
         let mluFwd = if fwd then Just lu else Nothing
@@ -154,7 +161,7 @@ behavior manager postSignedHeaders micros (ObjURI h lu) = \case
             liftIO $ retry shouldRetry toException $
                 AP.deliver manager postSignedHeaders envelope mluFwd uInbox
         done ()
-    MethodForwardRemote errand -> do
+    Right errand -> do
         uInbox <- getInbox
         _resp <-
             liftIO $ retry shouldRetry toException $
@@ -244,9 +251,24 @@ startDeliveryTheater headers micros manager logFunc dbRootDir = do
         return (u, env)
     DeliveryTheater manager headers micros logFunc dbRootDir <$> startTheater logFunc (actors `H.HCons` H.HNil)
 
-sendHttp :: UriMode u => DeliveryTheater u -> ActorMessage (DeliveryActor u) -> [ObjURI u] -> IO ()
+data DeliveryMethod u
-sendHttp (DeliveryTheater manager headers micros logFunc root theater) method recips = do
+    = MethodDeliverLocal (AP.Envelope u) Bool
-    for_ recips $ \ u ->
+    | MethodForwardRemote (AP.Errand 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
+-- Since sendManyIO isn't available right now, we're using many sendIO
-    sendManyIO theater $ Just (HS.fromList recips, method) `H.HCons` H.HNil
+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

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
+    commit: 0b38f114ebe3ef9b64c7670a3a8497c0857ff2cd
-  - git: https://codeberg.org/ForgeFed/darcs-lights
-    commit: c6005155bcd28f6e4243e8cafed1bd61384cae48
   - 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
+  - HList-0.5.3.0
-  - cipher-aes128-0.7.0.6
   - SimpleAES-0.4.2
-  - darcs-2.16.5
+  - email-validate-json-0.1.0.0
-  - constraints-0.12
-#  - data-default-instances-bytestring-0.0.1
-#  - esqueleto-2.7.0
-#  - graphviz-2999.20.0.3
   - highlighter2-0.2.5
   - libravatar-0.4.0.2
-  - monad-hash-0.1.0.2
+  - smtp-mail-0.4.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
   - time-interval-0.1.1
-#  - time-units-1.0.0
+  - vary-0.1.0.3
-#  - 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
 
 # Override default flag values for local packages and extra-deps
 flags:

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