mirror of https://github.com/voidlizard/hbs2
92 lines
2.1 KiB
Haskell
92 lines
2.1 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
module Main where
|
|
|
|
import HBS2.Git3.Prelude
|
|
import HBS2.Git3.Run
|
|
|
|
import HBS2.Data.Log.Structured
|
|
|
|
import HBS2.Git3.Config.Local
|
|
|
|
import Data.Config.Suckless.Script
|
|
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Network.ByteOrder qualified as N
|
|
import Data.HashSet qualified as HS
|
|
import Data.HashSet (HashSet(..))
|
|
import Streaming.Prelude qualified as S
|
|
|
|
import System.Environment qualified as E
|
|
import Crypto.Hash qualified as C
|
|
|
|
{- HLINT ignore "Functor law" -}
|
|
{- HLINT ignore "Eta reduce" -}
|
|
|
|
readIndexFromFile :: forall m . MonadIO m
|
|
=> FilePath
|
|
-> m (HashSet GitHash)
|
|
readIndexFromFile fname = do
|
|
|
|
bs <- liftIO $ LBS.readFile fname
|
|
|
|
r <- S.toList_ $ runConsumeLBS bs $ flip fix 0 \go n -> do
|
|
done <- noBytesLeft
|
|
if done then pure ()
|
|
else do
|
|
_ <- readBytesMaybe 4
|
|
>>= orThrow SomeReadLogError
|
|
<&> fromIntegral . N.word32 . LBS.toStrict
|
|
|
|
hash <- readBytesMaybe 20
|
|
>>= orThrow SomeReadLogError
|
|
<&> GitHash . LBS.toStrict
|
|
|
|
lift (S.yield hash)
|
|
go (succ n)
|
|
|
|
pure $ HS.fromList r
|
|
|
|
|
|
-- debugPrefix :: LoggerEntry -> LoggerEntry
|
|
debugPrefix = toStderr . logPrefix "[debug] "
|
|
|
|
setupLogger :: MonadIO m => m ()
|
|
setupLogger = do
|
|
-- setLogging @DEBUG $ toStderr . logPrefix "[debug] "
|
|
setLogging @ERROR $ toStderr . logPrefix "[error] "
|
|
setLogging @WARN $ toStderr . logPrefix "[warn] "
|
|
setLogging @NOTICE $ toStdout . logPrefix ""
|
|
pure ()
|
|
|
|
flushLoggers :: MonadIO m => m ()
|
|
flushLoggers = do
|
|
silence
|
|
|
|
silence :: MonadIO m => m ()
|
|
silence = do
|
|
setLoggingOff @DEBUG
|
|
setLoggingOff @ERROR
|
|
setLoggingOff @WARN
|
|
setLoggingOff @NOTICE
|
|
|
|
main :: IO ()
|
|
main = flip runContT pure do
|
|
|
|
setupLogger
|
|
|
|
ContT $ bracket none $ const do
|
|
silence
|
|
|
|
argz <- liftIO $ E.getArgs
|
|
cli <- parseTop (unlines $ unwords <$> splitForms argz)
|
|
& either (error.show) pure
|
|
|
|
env <- nullGit3Env
|
|
|
|
void $ lift $ withGit3Env env do
|
|
conf <- readLocalConf
|
|
let dict = theDict
|
|
recover $ setupLogger >> run dict (conf <> cli)
|
|
`finally` silence
|
|
|