mirror of https://github.com/voidlizard/hbs2
725 lines
21 KiB
Haskell
725 lines
21 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
module Main where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Actors.Peer
|
|
import HBS2.Base58
|
|
import HBS2.OrDie
|
|
import HBS2.Hash
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.Polling
|
|
import HBS2.Misc.PrettyStuff
|
|
import HBS2.System.Dir
|
|
import HBS2.System.Logger.Simple.ANSI hiding (info)
|
|
import HBS2.Net.Messaging.Unix
|
|
|
|
import HBS2.Git.Data.LWWBlock
|
|
|
|
import HBS2.Net.Proto.Notify
|
|
import HBS2.Net.Proto.Service
|
|
import HBS2.Peer.Notify
|
|
import HBS2.Peer.RPC.API.Peer
|
|
import HBS2.Peer.RPC.API.RefLog
|
|
import HBS2.Peer.RPC.API.LWWRef
|
|
import HBS2.Peer.RPC.API.Storage
|
|
import HBS2.Peer.RPC.Client.StorageClient
|
|
|
|
import HBS2.Peer.CLI.Detect
|
|
import HBS2.Peer.Proto.RefLog
|
|
|
|
import Data.Config.Suckless
|
|
|
|
import Data.Time.Clock
|
|
import Data.Coerce
|
|
import Control.Monad.Reader
|
|
import Lens.Micro.Platform
|
|
import System.Directory
|
|
import Options.Applicative
|
|
import Data.Maybe
|
|
import Data.Either
|
|
import Data.HashMap.Strict (HashMap)
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Control.Monad.Trans.Cont
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.ByteString.Lazy.Char8 qualified as LBS
|
|
import Data.Text qualified as Text
|
|
import Data.Hashable
|
|
import Control.Exception qualified as E
|
|
import System.Process.Typed
|
|
import System.Environment qualified as Env
|
|
import System.Exit qualified as Exit
|
|
import Data.Cache qualified as Cache
|
|
import Data.Cache (Cache)
|
|
|
|
import System.Exit
|
|
|
|
{- HLINT ignore "Functor law" -}
|
|
|
|
|
|
type Config = [Syntax C]
|
|
|
|
|
|
type RLWW = LWWRefKey 'HBS2Basic
|
|
type RRefLog = RefLogKey 'HBS2Basic
|
|
|
|
newtype Watcher =
|
|
Watcher [Syntax C]
|
|
deriving newtype (Semigroup,Monoid)
|
|
|
|
data Ref =
|
|
RefRefLog RRefLog
|
|
| RefLWW RLWW
|
|
deriving stock (Eq,Generic)
|
|
|
|
instance Pretty Ref where
|
|
pretty (RefRefLog r) = parens $ "reflog" <+> dquotes (pretty r)
|
|
pretty (RefLWW r) = parens $ "lwwref" <+> dquotes (pretty r)
|
|
|
|
newtype AnyPolledRef =
|
|
AnyPolledRef (PubKey 'Sign 'HBS2Basic)
|
|
deriving (Eq,Generic)
|
|
|
|
instance Hashable AnyPolledRef
|
|
|
|
-- FIXME: move-to-suckless-conf
|
|
deriving newtype instance Hashable Id
|
|
|
|
instance Pretty AnyPolledRef where
|
|
pretty (AnyPolledRef r) = pretty (AsBase58 r)
|
|
-- deriving newtype instance Pretty (PubKey 'Sign 'HBS2Basic) => Pretty AnyPolledRef
|
|
|
|
instance FromStringMaybe AnyPolledRef where
|
|
fromStringMay = fmap AnyPolledRef . fromStringMay
|
|
|
|
newtype PolledRef =
|
|
PolledRef (Ref, NominalDiffTime)
|
|
deriving stock (Eq,Generic)
|
|
deriving newtype (Pretty)
|
|
|
|
instance Hashable Ref
|
|
|
|
instance Hashable PolledRef where
|
|
hashWithSalt salt (PolledRef (r,_)) = hashWithSalt salt r
|
|
|
|
data FixerEnv = FixerEnv
|
|
{ _configFile :: Maybe FilePath
|
|
, _lwwAPI :: ServiceCaller LWWRefAPI UNIX
|
|
, _refLogAPI :: ServiceCaller RefLogAPI UNIX
|
|
, _refLogSink :: NotifySink (RefLogEvents L4Proto) UNIX
|
|
, _peerAPI :: ServiceCaller PeerAPI UNIX
|
|
, _sto :: AnyStorage
|
|
, _config :: TVar Config
|
|
, _configPoll :: TVar Int
|
|
, _watchers :: TVar (HashMap PolledRef Watcher)
|
|
, _listeners :: TVar (HashMap RRefLog (Async ()))
|
|
, _result :: TVar (HashMap Ref (Maybe HashRef, Maybe HashRef))
|
|
, _runNum :: TVar Int
|
|
, _locals :: TVar (HashMap Id (Syntax C))
|
|
, _pipeline :: TQueue (IO ())
|
|
}
|
|
|
|
makeLenses ''FixerEnv
|
|
|
|
|
|
newtype FixerM m a = FixerM { runFixerM :: ReaderT FixerEnv m a }
|
|
deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader FixerEnv, MonadUnliftIO)
|
|
|
|
instance MonadIO m => HasConf (FixerM m) where
|
|
getConf = asks _config >>= readTVarIO
|
|
|
|
|
|
debugPrefix = toStdout . logPrefix "[debug] "
|
|
|
|
readConf :: MonadIO m => FilePath -> m [Syntax C]
|
|
readConf fn = liftIO (readFile fn) <&> parseTop <&> fromRight mempty
|
|
|
|
withConfig :: MonadUnliftIO m => Maybe FilePath -> FixerM m () -> FixerM m ()
|
|
withConfig cfgPath m = do
|
|
defConfDir <- liftIO $ getXdgDirectory XdgConfig "hbs2-fixer"
|
|
|
|
let configPath = fromMaybe (defConfDir </> "config") cfgPath
|
|
unless (isJust cfgPath) do
|
|
debug $ pretty configPath
|
|
touch configPath
|
|
|
|
syn <- readConf configPath
|
|
tsyn <- newTVarIO syn
|
|
|
|
local (set config tsyn . set configFile (Just configPath)) (void m)
|
|
|
|
withApp :: Maybe FilePath -> FixerM IO () -> IO ()
|
|
withApp cfgPath action = do
|
|
setLogging @DEBUG debugPrefix
|
|
setLogging @INFO defLog
|
|
setLogging @ERROR errorPrefix
|
|
setLogging @WARN warnPrefix
|
|
setLogging @NOTICE noticePrefix
|
|
|
|
fix \next -> do
|
|
|
|
flip runContT pure do
|
|
|
|
soname' <- lift detectRPC
|
|
|
|
soname <- ContT $ maybe1 soname' (pure ())
|
|
|
|
client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
|
|
>>= orThrowUser ("can't connect to" <+> pretty soname)
|
|
|
|
mess <- ContT $ withAsync $ runMessagingUnix client
|
|
|
|
peerAPI <- makeServiceCaller @PeerAPI (fromString soname)
|
|
refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname)
|
|
storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
|
|
lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname)
|
|
|
|
let endpoints = [ Endpoint @UNIX peerAPI
|
|
, Endpoint @UNIX refLogAPI
|
|
, Endpoint @UNIX lwwAPI
|
|
, Endpoint @UNIX storageAPI
|
|
]
|
|
|
|
mn <- ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
|
|
|
let o = [MUDontRetry]
|
|
clientN <- newMessagingUnixOpts o False 1.0 soname
|
|
|
|
notif <- ContT $ withAsync (runMessagingUnix clientN)
|
|
|
|
|
|
sink <- newNotifySink
|
|
|
|
void $ ContT $ withAsync $ flip runReaderT clientN $ do
|
|
debug $ red "notify restarted!"
|
|
runNotifyWorkerClient sink
|
|
|
|
p1 <- ContT $ withAsync $ flip runReaderT clientN $ do
|
|
runProto @UNIX
|
|
[ makeResponse (makeNotifyClient @(RefLogEvents L4Proto) sink)
|
|
]
|
|
|
|
env <- FixerEnv Nothing
|
|
lwwAPI
|
|
refLogAPI
|
|
sink
|
|
peerAPI
|
|
(AnyStorage (StorageClient storageAPI))
|
|
<$> newTVarIO mempty
|
|
<*> newTVarIO 30
|
|
<*> newTVarIO mempty
|
|
<*> newTVarIO mempty
|
|
<*> newTVarIO mempty
|
|
<*> newTVarIO 0
|
|
<*> newTVarIO mempty
|
|
<*> newTQueueIO
|
|
|
|
void $ ContT $ bracket (pure ()) $ \_ -> do
|
|
readTVarIO (_listeners env) <&> HM.elems >>= mapM_ cancel
|
|
|
|
p3 <- ContT $ withAsync $ runReaderT (runFixerM $ withConfig cfgPath action) env
|
|
|
|
void $ waitAnyCatchCancel [mess,mn,notif,p1,p3]
|
|
|
|
debug $ red "respawning..."
|
|
pause @'Seconds 5
|
|
next
|
|
|
|
setLoggingOff @DEBUG
|
|
setLoggingOff @INFO
|
|
setLoggingOff @ERROR
|
|
setLoggingOff @WARN
|
|
setLoggingOff @NOTICE
|
|
|
|
where
|
|
errorPrefix = toStdout . logPrefix "[error] "
|
|
warnPrefix = toStdout . logPrefix "[warn] "
|
|
noticePrefix = toStdout
|
|
|
|
|
|
data ConfWatch =
|
|
ConfWatch
|
|
| ConfRead
|
|
| ConfUpdate [Syntax C]
|
|
|
|
mainLoop :: FixerM IO ()
|
|
mainLoop = do
|
|
debug "hbs2-fixer. do stuff since 2024"
|
|
conf <- getConf
|
|
-- debug $ line <> vcat (fmap pretty conf)
|
|
|
|
flip runContT pure do
|
|
|
|
debug $ red "Reloading..."
|
|
|
|
lift $ updateFromConfig conf
|
|
|
|
p1 <- ContT $ withAsync $ do
|
|
cfg <- asks _configFile `orDie` "config file not specified"
|
|
|
|
flip fix ConfRead $ \next -> \case
|
|
ConfRead -> do
|
|
debug $ yellow "read config" <+> pretty cfg
|
|
newConf <- readConf cfg
|
|
oldConf <- getConf
|
|
|
|
let a = hashObject @HbSync (LBS.pack $ show $ pretty newConf)
|
|
let b = hashObject @HbSync (LBS.pack $ show $ pretty oldConf)
|
|
|
|
let changed = a /= b
|
|
|
|
if not changed then
|
|
next ConfWatch
|
|
else
|
|
next (ConfUpdate newConf)
|
|
|
|
ConfUpdate new -> do
|
|
debug $ yellow "read config / update state"
|
|
updateFromConfig new
|
|
next ConfWatch
|
|
|
|
ConfWatch{} -> do
|
|
w <- asks _configPoll >>= readTVarIO
|
|
pause (TimeoutSec (realToFrac w))
|
|
next ConfRead
|
|
|
|
-- poll reflogs
|
|
p2 <- ContT $ withAsync do
|
|
|
|
let w = asks _watchers
|
|
>>= readTVarIO
|
|
<&> HM.toList
|
|
<&> \wtf -> [ (ByFirst r wa, t) | (PolledRef (r,t), wa) <- wtf ]
|
|
|
|
polling (Polling 1 1) w $ \case
|
|
ByFirst ref wa -> do
|
|
new <- getRefRpc ref
|
|
re <- asks _result
|
|
old <- readTVarIO re
|
|
<&> (snd <=< HM.lookup ref)
|
|
|
|
when (new /= old) do
|
|
atomically $ modifyTVar re (HM.insert ref (old, new))
|
|
-- bindId
|
|
forM_ new (runWatcher wa ref)
|
|
|
|
pure ()
|
|
|
|
jobs <- asks _pipeline
|
|
p3 <- ContT $ withAsync $ fix \next -> do
|
|
r <- liftIO $ E.try @SomeException (join $ atomically $ readTQueue jobs)
|
|
case r of
|
|
Left e -> do
|
|
err (viaShow e)
|
|
let ee = fromException @AsyncCancelled e
|
|
|
|
unless (isJust ee) do
|
|
next
|
|
|
|
_ -> next
|
|
|
|
void $ waitAnyCatchCancel [p1,p2,p3]
|
|
|
|
oneSec :: MonadUnliftIO m => m b -> m (Either () b)
|
|
oneSec = race (pause @'Seconds 1)
|
|
|
|
|
|
fromStrLitMay :: forall s c . FromStringMaybe s => Syntax c -> Maybe s
|
|
fromStrLitMay = \case
|
|
LitStrVal s -> fromStringMay (Text.unpack s)
|
|
_ -> Nothing
|
|
|
|
pattern PTop :: forall {c}. Id -> [Syntax c] -> Syntax c
|
|
pattern PTop ctor rest <- ListVal (SymbolVal ctor : rest)
|
|
|
|
pattern PPolledRef :: forall {c}. Id -> AnyPolledRef -> Syntax c
|
|
pattern PPolledRef t r <- ListVal [ SymbolVal t, fromStrLitMay @AnyPolledRef -> Just r ]
|
|
|
|
pattern PWatchRef :: forall {c}. Integer -> Id -> AnyPolledRef -> [Syntax c] -> [Syntax c]
|
|
pattern PWatchRef n t r w <- (LitIntVal n : PPolledRef t r : w)
|
|
|
|
pattern PListenRef :: forall {c}. Id -> AnyPolledRef -> [Syntax c] -> [Syntax c]
|
|
pattern PListenRef t r w <- (PPolledRef t r : w)
|
|
|
|
-- pattern PDisplay :: Syntax c
|
|
pattern PDisplay :: forall {c}. Syntax c -> Syntax c
|
|
pattern PDisplay w <- ListVal [ SymbolVal "display", w ]
|
|
|
|
pattern PApply :: Id -> [Syntax C] -> Syntax C
|
|
pattern PApply f a <- ListVal ( SymbolVal f : a )
|
|
|
|
fetchRef :: forall m . MonadIO m => Ref -> FixerM m ()
|
|
fetchRef r = do
|
|
case r of
|
|
RefRefLog ref -> do
|
|
api <- asks _refLogAPI
|
|
void $ liftIO $ oneSec $ void $ callService @RpcRefLogFetch api (fromRefLogKey ref)
|
|
RefLWW ref -> do
|
|
api <- asks _lwwAPI
|
|
void $ liftIO $ oneSec $ void $ callService @RpcLWWRefFetch api ref
|
|
|
|
|
|
getRefRpc :: forall m . MonadIO m => Ref -> FixerM m (Maybe HashRef)
|
|
getRefRpc r = do
|
|
case r of
|
|
RefRefLog ref -> do
|
|
api <- asks _refLogAPI
|
|
liftIO (oneSec $ callService @RpcRefLogGet api (fromRefLogKey ref))
|
|
>>= \case
|
|
Right (Right x) -> pure x
|
|
_ -> pure Nothing
|
|
|
|
RefLWW ref -> do
|
|
api <- asks _lwwAPI
|
|
liftIO (oneSec $ callService @RpcLWWRefGet api ref) >>= \case
|
|
Right (Right x) -> pure (lwwValue <$> x)
|
|
_ -> pure Nothing
|
|
|
|
subscribeRef :: forall m . MonadIO m => Integer -> Ref -> FixerM m ()
|
|
subscribeRef n r = do
|
|
debug $ "subscribeRef" <+> pretty n <+> pretty r
|
|
let (puk,t) = case r of
|
|
RefRefLog k -> (coerce k, "reflog")
|
|
RefLWW k -> (coerce k, "lwwref")
|
|
|
|
let minutes = fromIntegral $ max 1 (n `div` 60)
|
|
|
|
api <- asks _peerAPI
|
|
void $ liftIO $ oneSec $ callService @RpcPollAdd api (puk, t, minutes)
|
|
|
|
asRef :: Id -> AnyPolledRef -> Maybe Ref
|
|
asRef t r = case t of
|
|
"lwwref" -> Just $ RefLWW (coerce r)
|
|
"reflog" -> Just $ RefRefLog (coerce r)
|
|
_ -> Nothing
|
|
|
|
|
|
runWatcher :: forall m . MonadUnliftIO m => Watcher -> Ref -> HashRef -> FixerM m ()
|
|
runWatcher (Watcher code) ref new = do
|
|
debug $ yellow "CHANGED" <+> pretty ref <+> pretty new
|
|
|
|
sto <- asks _sto
|
|
|
|
newCode <- flip transformBiM code $ \case
|
|
PApply "lwwref:get-hbs2-git-reflog" _ -> do
|
|
v <- case ref of
|
|
RefLWW k -> readLWWBlock sto k
|
|
_ -> pure Nothing
|
|
|
|
-- FIXME: wrappers-for-syntax-ctors
|
|
let vv = maybe1 v (List (noContext @C) mempty) $
|
|
\(_, LWWBlockData{..}) ->
|
|
List (noContext @C) [ Symbol (noContext @C) "reflog"
|
|
, Literal (noContext @C)
|
|
(mkLit @Text (fromString $ show $ pretty (AsBase58 lwwRefLogPubKey)))
|
|
]
|
|
pure vv
|
|
|
|
w -> pure w
|
|
|
|
debug (pretty newCode)
|
|
runConfig newCode
|
|
|
|
|
|
|
|
display :: forall m . MonadUnliftIO m => Syntax C -> FixerM m ()
|
|
display what = do
|
|
case what of
|
|
LitStrVal s -> notice (pretty s)
|
|
ast -> notice (pretty ast)
|
|
|
|
list_ :: [Syntax C] -> Syntax C
|
|
list_ = List (noContext @C)
|
|
|
|
symbol_ :: Id -> Syntax C
|
|
symbol_ = Symbol (noContext @C)
|
|
|
|
str_ :: Text -> Syntax C
|
|
str_ s = Literal (noContext @C) (LitStr s)
|
|
|
|
int_ :: Integer -> Syntax C
|
|
int_ s = Literal (noContext @C) (LitInt s)
|
|
|
|
bool_ :: Bool -> Syntax C
|
|
bool_ s = Literal (noContext @C) (LitBool s)
|
|
|
|
-- FIXME: to-suckless-conf
|
|
class AsString s where
|
|
asString :: s -> String
|
|
|
|
instance AsString Literal where
|
|
asString (LitStr s) = Text.unpack s
|
|
asString other = show $ pretty other
|
|
|
|
instance AsString (Syntax c) where
|
|
asString (Literal _ x) = asString x
|
|
asString x = show $ pretty x
|
|
|
|
data RunOpts =
|
|
RunCWD FilePath
|
|
|
|
instance Pretty RunOpts where
|
|
pretty = \case
|
|
RunCWD f -> parens ("cwd" <+> pretty f)
|
|
|
|
eval :: forall m . MonadUnliftIO m => Syntax C -> FixerM m (Syntax C)
|
|
eval = eval'
|
|
-- debug $ "EVAL" <+> pretty syn <+> pretty r
|
|
-- pure r
|
|
|
|
eval' :: forall m . MonadUnliftIO m => Syntax C -> FixerM m (Syntax C)
|
|
eval' syn = do
|
|
|
|
case syn of
|
|
|
|
x@(Literal{}) -> pure x
|
|
|
|
(SymbolVal n) -> lookupLocal n
|
|
|
|
w@(PApply "list" code') -> do
|
|
code <- mapM unquote code'
|
|
pure $ list_ (symbol_ "list" : code)
|
|
|
|
PApply "local" [SymbolVal n, what] -> do
|
|
bindLocal n =<< eval what
|
|
pure nil
|
|
|
|
PApply "eval" [e] -> do
|
|
eval e >>= \case
|
|
(ListVal ( SymbolVal "list" : es ) ) -> do
|
|
lastDef nil <$> mapM eval es
|
|
|
|
_ -> pure nil
|
|
|
|
PApply "listen" (what' : code) -> do
|
|
what <- eval what'
|
|
case what of
|
|
PPolledRef "reflog" ref -> do
|
|
setReflogListener (coerce ref) =<< mapM unquote code
|
|
|
|
PPolledRef tp r -> do
|
|
warn $ yellow "not supported listener type" <+> pretty tp
|
|
|
|
_ -> pure ()
|
|
|
|
pure nil
|
|
|
|
PApply "watch" (p' : what' : watcher') -> do
|
|
p <- eval p'
|
|
what <- eval what'
|
|
watcher <- mapM unquote watcher'
|
|
|
|
case (p, what) of
|
|
(LitIntVal n, PPolledRef tp ref) -> do
|
|
|
|
let re = asRef tp ref
|
|
|
|
forM_ re (subscribeRef n)
|
|
void $ async (pause @'Seconds 5 >> forM_ re fetchRef)
|
|
|
|
void $ runMaybeT do
|
|
|
|
-- FIXME: more-diagnostics
|
|
pref <- toMPlus $ case tp of
|
|
"lwwref" -> Just $ PolledRef (RefLWW (coerce ref), fromIntegral n)
|
|
"reflog" -> Just $ PolledRef (RefRefLog (coerce ref), fromIntegral n)
|
|
_ -> Nothing
|
|
|
|
debug $ blue "watch" <+> pretty n <+> pretty tp <+> pretty ref
|
|
w <- asks _watchers
|
|
atomically $ modifyTVar w (HM.insert pref (Watcher watcher))
|
|
|
|
_ -> pure ()
|
|
|
|
pure nil
|
|
|
|
PApply "on-start" wtf -> do
|
|
|
|
rn <- asks _runNum
|
|
rnn <- atomically do
|
|
x <- readTVar rn
|
|
modifyTVar rn succ
|
|
pure x
|
|
|
|
when (rnn == 0) do
|
|
mapM_ eval wtf
|
|
|
|
pure nil
|
|
|
|
PApply fn args' -> do
|
|
args <- mapM eval args'
|
|
case fn of
|
|
|
|
"reflog" -> do
|
|
pure $ list_ (symbol_ "reflog" : args)
|
|
|
|
"lwwref" -> do
|
|
pure $ list_ (symbol_ "lwwref" : args)
|
|
|
|
"watch-config" -> do
|
|
case headDef (int_ 30) args of
|
|
LitIntVal n -> do
|
|
debug $ "watch-config" <+> pretty n
|
|
asks _configPoll >>= atomically . flip writeTVar (fromIntegral n)
|
|
_ -> do
|
|
pure ()
|
|
|
|
pure nil
|
|
|
|
"debug" -> do
|
|
let onOff = headDef (bool_ False) args
|
|
case onOff of
|
|
LitBoolVal True -> do
|
|
setLogging @DEBUG debugPrefix
|
|
_ -> do
|
|
setLoggingOff @DEBUG
|
|
|
|
pure nil
|
|
|
|
"string-append" -> do
|
|
pieces <- for args $ \case
|
|
LitStrVal s -> pure s
|
|
other -> pure (Text.pack $ show $ pretty other)
|
|
|
|
pure $ str_ $ mconcat pieces
|
|
|
|
"display" -> do
|
|
first <- headDef nil <$> mapM eval args
|
|
case first of
|
|
LitStrVal s -> notice (pretty s)
|
|
ast -> notice (pretty ast)
|
|
|
|
pure nil
|
|
|
|
"getenv" -> do
|
|
let name = asString $ headDef nil args
|
|
liftIO $ Env.lookupEnv name
|
|
>>= \case
|
|
Nothing -> pure nil
|
|
Just s -> pure $ str_ (fromString s)
|
|
|
|
"mkdir" -> do
|
|
debug $ "mkdir" <+> pretty args
|
|
mapM_ mkdir [ Text.unpack s | (LitStrVal s) <- args ]
|
|
pure nil
|
|
|
|
"exit" -> do
|
|
case headDef (int_ 0) args of
|
|
LitIntVal 0 -> liftIO Exit.exitSuccess
|
|
LitIntVal w -> liftIO $ Exit.exitWith (ExitFailure $ fromIntegral w)
|
|
_ -> liftIO Exit.exitFailure
|
|
|
|
pure nil
|
|
|
|
"run" -> do
|
|
debug $ red "RUN-ARGS" <+> pretty args
|
|
(o,cargs) <- case args of
|
|
(ListVal (SymbolVal "list" : SymbolVal "opts" : opts) : rest) -> do
|
|
let pairs = [ (opt, e) | ListVal [SymbolVal opt, e] <- opts ]
|
|
oo <- for pairs $ \(o, e) -> (o,) <$> eval e
|
|
let cwd = lastMay [ RunCWD (Text.unpack f )
|
|
| ("cwd", LitStrVal f) <- oo
|
|
]
|
|
pure (maybeToList cwd, rest)
|
|
|
|
rest -> do
|
|
pure (mempty, rest)
|
|
|
|
let what = unwords $ [Text.unpack s | LitStrVal s <- cargs]
|
|
|
|
let cwd = case headMay [ p | c@(RunCWD p) <- o ] of
|
|
Just c -> setWorkingDir c
|
|
_ -> id
|
|
|
|
debug $ red "RUN" <+> pretty what <+> pretty o
|
|
|
|
let job = void $ runProcess_ (shell what & cwd)
|
|
pip <- asks _pipeline
|
|
atomically $ writeTQueue pip job
|
|
|
|
pure nil
|
|
|
|
_ -> pure nil
|
|
|
|
|
|
_ -> pure nil
|
|
|
|
|
|
unquote :: forall code m . (code ~ Syntax C, MonadUnliftIO m) => code -> FixerM m code
|
|
unquote code = flip transformBiM code $ \case
|
|
x@(ListVal [SymbolVal "unquoted", rest] :: Syntax C) -> do
|
|
eval rest
|
|
|
|
x -> pure x
|
|
|
|
setReflogListener :: forall m . MonadUnliftIO m => RRefLog -> [Syntax C] -> FixerM m ()
|
|
setReflogListener reflog code = do
|
|
debug $ green "setReflogListener" <+> pretty reflog <> line <> pretty code
|
|
|
|
dudes <- asks _listeners
|
|
|
|
a <- atomically do
|
|
x <- readTVar dudes <&> HM.lookup reflog
|
|
modifyTVar dudes (HM.delete reflog)
|
|
pure x
|
|
|
|
maybe1 a none cancel
|
|
|
|
sink <- asks _refLogSink
|
|
|
|
debug $ "subscribe to" <+> pretty reflog
|
|
|
|
new <- async do
|
|
cache <- liftIO $ Cache.newCache (Just (toTimeSpec (TimeoutSec 10)))
|
|
|
|
runNotifySink sink (RefLogNotifyKey reflog) $ \(RefLogUpdateNotifyData _ h) -> do
|
|
debug $ "Got notification" <+> pretty reflog <+> pretty h
|
|
here <- liftIO (Cache.lookup cache (reflog, h)) <&> isJust
|
|
unless here do
|
|
liftIO $ Cache.insert cache (reflog,h) ()
|
|
runConfig code
|
|
|
|
atomically $ modifyTVar dudes (HM.insert reflog new)
|
|
|
|
bindLocal :: forall m . MonadUnliftIO m => Id -> Syntax C -> FixerM m ()
|
|
bindLocal l e = do
|
|
-- debug $ "bindLocal" <+> pretty l
|
|
asks _locals >>= atomically . flip modifyTVar (HM.insert l e)
|
|
|
|
lookupLocal :: forall m . MonadUnliftIO m => Id ->FixerM m (Syntax C)
|
|
lookupLocal name = do
|
|
-- debug $ "lookupLocal" <+> pretty name
|
|
asks _locals >>= readTVarIO <&> fromMaybe nil . HM.lookup name
|
|
|
|
runConfig :: forall m . MonadUnliftIO m => Config -> FixerM m ()
|
|
runConfig conf = do
|
|
debug $ green "runConfig"
|
|
bindLocal "off" (bool_ False)
|
|
bindLocal "on" (bool_ True)
|
|
|
|
mapM_ eval conf
|
|
|
|
updateFromConfig :: MonadUnliftIO m => Config -> FixerM m ()
|
|
updateFromConfig conf = do
|
|
asks _config >>= atomically . flip writeTVar conf
|
|
runConfig conf
|
|
|
|
main :: IO ()
|
|
main = do
|
|
runMe =<< customExecParser (prefs showHelpOnError)
|
|
( info (helper <*> opts)
|
|
( fullDesc
|
|
<> header "hbs2-fixer"
|
|
<> progDesc "Intermediary between hbs2-peer and external applications. Listen events / do stuff"
|
|
))
|
|
|
|
where
|
|
opts = optional $ strOption (short 'c' <> long "config" <> metavar "FILE" <> help "Specify configuration file")
|
|
|
|
runMe opt = withApp opt mainLoop
|
|
|