mirror of https://github.com/voidlizard/hbs2
git-hbs2-http - very basic git http dumb algorithm
for fetching repos from hbs2-git for third-side programs (like nix). pushes are not supported (yet?).
This commit is contained in:
Dmitry Zuikov
parent
55cdf976da
commit
0af3056664
|
|
@ -0,0 +1,27 @@
|
|||
FIXME: hbs2-git-config-path-ux
|
||||
1. Пользователю неочевидно, где этот конфиг искать ( ~/.local/config/hbs2-git/repo/config )
|
||||
2. Если пользователь переименует репозиторий, то путь к конфигу станет неактуален
|
||||
и это вызовет непонятную внезапную проблему.
|
||||
|
||||
Решение:
|
||||
Пока непонятно. Если привязаться к inode, то при перемещении между FS будет ломаться,
|
||||
и кроссплатформенность пострадает.
|
||||
|
||||
Кажется, при инициализации репо надо заводить cookie, и сохранять её в конфиге гита (буэ).
|
||||
Тогда все операции ведутся через эту cookie, все развязки в стейте через эту cookie,
|
||||
тогда importRefLogNew начинает работать с многими каталогами git, стейт с одной
|
||||
стороны глобальный, с другой стороны зависит от cookie.
|
||||
|
||||
Если пользователь специально или случайно удалит/поменяет cookie -- то импорт для этого
|
||||
репозитория пойдёт заново (ну и что, мы этого и хотели. глобальный у нас
|
||||
только logobject и связаные с ним вью и таблицы, а таблицы, которые отмечают
|
||||
обработанные данные --- имеют локальный смысл. )
|
||||
|
||||
Кроме того, надо задуматься о перемещении конфига в каталог гит локально,
|
||||
что бы избежать проблем 1 и 2.
|
||||
|
||||
Введение конфига, привязанного к cookie, еще больше усугубит проблему (1), но решит
|
||||
в принципе проблему 2.
|
||||
|
||||
От конфига нам, кстати, вообще ничего не нужно, кроме указания ключа записи в рефлог.
|
||||
Кажется, можно его просто упразднить или писать в тот же gitconfig.
|
||||
|
|
@ -0,0 +1,249 @@
|
|||
module Main where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Clock
|
||||
|
||||
import HBS2Git.App
|
||||
import HBS2Git.State
|
||||
import HBS2Git.Import (getLogFlags, importRefLogNew)
|
||||
import HBS2Git.GitRepoLog
|
||||
import HBS2.Git.Types
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Data.Detect (deepScan,ScanLevel(..))
|
||||
import HBS2.OrDie
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Codec.Compression.Zlib (compress)
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS
|
||||
import Data.Function
|
||||
import Data.Functor
|
||||
import Data.HashMap.Strict as HashMap
|
||||
import Data.List (sortOn)
|
||||
import Data.Text.Lazy qualified as Text
|
||||
import Lens.Micro.Platform
|
||||
import Network.HTTP.Types.Status
|
||||
import Network.Wai.Handler.Warp (Port)
|
||||
import Network.Wai.Middleware.RequestLogger
|
||||
import System.Directory
|
||||
import System.FilePath.Posix
|
||||
import System.IO.Temp
|
||||
import System.Timeout (timeout)
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import UnliftIO.Async
|
||||
|
||||
import Streaming.ByteString qualified as SB
|
||||
import Streaming.Zip qualified as SZip
|
||||
|
||||
import Web.Scotty
|
||||
|
||||
instance Parsable RepoRef where
|
||||
parseParam txt = fromStringMay @RepoRef (Text.unpack txt)
|
||||
& maybe (Left [qc|{txt}|]) Right
|
||||
|
||||
instance Parsable GitRef where
|
||||
parseParam txt = Right $ fromString (Text.unpack txt)
|
||||
|
||||
getAppStatePath :: MonadIO m => RepoRef -> m FilePath
|
||||
getAppStatePath repo = do
|
||||
stateDir <- getAppStateDir
|
||||
pure $ stateDir </> show (pretty repo)
|
||||
|
||||
|
||||
blockSource :: MonadIO m => API -> HashRef -> SB.ByteStream m ()
|
||||
blockSource api h = do
|
||||
deepScan ScanDeep (const none) (fromHashRef h) (readBlockFrom api . HashRef) $ \ha -> do
|
||||
sec <- lift $ readBlockFrom api (HashRef ha) `orDie` [qc|missed block {pretty ha}|]
|
||||
when (h /= HashRef ha) do
|
||||
SB.fromLazy sec
|
||||
|
||||
unpackObjects :: MonadIO m => API -> HashRef -> FilePath -> m ()
|
||||
unpackObjects catApi lo path = do
|
||||
|
||||
let logPath = path </> show (pretty lo)
|
||||
let logFile = logPath </> "data"
|
||||
|
||||
liftIO $ createDirectoryIfMissing True logPath
|
||||
|
||||
flags <- getLogFlags (readBlockFrom catApi) lo
|
||||
let gzipped = or $ False : [ True | "gz" <- universeBi flags ]
|
||||
let unzipped = if gzipped then SZip.gunzip else id
|
||||
debug $ "GOT FLAGS:" <+> pretty lo <+> pretty flags
|
||||
|
||||
liftIO $ do
|
||||
runResourceT $ SB.writeFile logFile $ unzipped $ blockSource catApi lo
|
||||
|
||||
gitRepoLogScan True logFile $ \entry mlbs -> do
|
||||
|
||||
let tp = case view gitLogEntryType entry of
|
||||
GitLogEntryCommit -> Just Commit
|
||||
GitLogEntryTree -> Just Tree
|
||||
GitLogEntryBlob -> Just Blob
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
let r = (,,) <$> tp
|
||||
<*> view gitLogEntryHash entry
|
||||
<*> mlbs
|
||||
|
||||
maybe1 r none $ \(t, eh, lbs) -> do
|
||||
let fname = logPath </> show (pretty eh)
|
||||
let pref = fromString (show (pretty t) <> " " <> show (LBS.length lbs) <> "\0")
|
||||
-- debug $ "writing object" <+> pretty eh <+> pretty (LBS.unpack $ LBS.takeWhile (/= '\0') pref)
|
||||
let co = compress (pref <> lbs)
|
||||
liftIO $ LBS.writeFile fname co
|
||||
|
||||
retryFor :: RealFrac r => Int -> r -> Timeout 'Seconds -> IO a -> IO (Maybe a)
|
||||
retryFor num waity sleep action = timeout (ceiling $ waity * 1000000) $ go num
|
||||
where
|
||||
go 0 = action
|
||||
go n = ( (Just <$> action) `catch` handler ) >>= maybe (go (n-1)) pure
|
||||
handler (_ :: SomeException) = pause @'Seconds sleep >> pure Nothing
|
||||
|
||||
dumbHttpServe :: MonadUnliftIO m => Port -> m ()
|
||||
dumbHttpServe pnum = do
|
||||
|
||||
locks <- liftIO $ newMVar (HashMap.empty @HashRef @(MVar ()))
|
||||
|
||||
catApi <- liftIO (retryFor 100 30 0.5 detectHBS2PeerCatAPI) `orDie` [qc|Can't locate hbs2-peer API|]
|
||||
|
||||
notice $ "hbs2-peer API:" <+> pretty catApi
|
||||
|
||||
-- TODO: lru-like-cache-for-unpacked-logs
|
||||
-- Деражть кэш, обновлять в нём таймстемпы
|
||||
-- доступа к логам.
|
||||
-- как только запись протухла - сносить каталог
|
||||
-- с логом, тогда в следующий раз будет обратно
|
||||
-- распакован
|
||||
|
||||
updater <- async $ forever do
|
||||
pause @'Seconds 300
|
||||
pure ()
|
||||
|
||||
runResourceT do
|
||||
|
||||
let myTempDir = "hbs-git-http"
|
||||
temp <- liftIO getCanonicalTemporaryDirectory
|
||||
|
||||
(_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
|
||||
|
||||
|
||||
liftIO $ scotty pnum $ do
|
||||
|
||||
middleware logStdoutDev
|
||||
|
||||
get "/:repo/info/refs" $ do
|
||||
repo <- param @RepoRef "repo"
|
||||
res <- liftIO do
|
||||
db <- makeDbPath repo >>= dbEnvReadOnly
|
||||
refs <- withDB db stateGetActualRefs
|
||||
let answ = Text.unlines $ Text.pack <$> [ show (pretty h) <> "\t" <> show (pretty r) | (r,h) <- refs ]
|
||||
shutdownDB db
|
||||
pure answ
|
||||
|
||||
text res
|
||||
|
||||
-- | REPO OBJECT REF
|
||||
get (regex "^/(.+)/(refs/.+)$") $ do
|
||||
repo <- fromString <$> param "1" -- reflog
|
||||
ref <- param "2" -- refname
|
||||
val <- liftIO do
|
||||
db <- makeDbPath repo >>= dbEnvReadOnly
|
||||
debug $ "QUERY: " <+> pretty ref
|
||||
val <- withDB db $ stateGetActualRefValue ref
|
||||
shutdownDB db
|
||||
pure val
|
||||
|
||||
maybe1 val (status status404) $ \x -> do
|
||||
text $ Text.pack $ show $ pretty x
|
||||
|
||||
get "/:repo/objects/:dd/:rest" $ do
|
||||
repo <- param @RepoRef "repo"
|
||||
dd <- param @String "dd"
|
||||
rest <- param @String "rest"
|
||||
let ha = fromString ( dd <> rest )
|
||||
|
||||
res <- runMaybeT do
|
||||
db <- liftIO $ makeDbPath repo >>= dbEnvReadOnly
|
||||
lo <- MaybeT $ liftIO $ withDB db $ stateGetGitLogObject ha
|
||||
shutdownDB db
|
||||
|
||||
let logDir = dir </> show (pretty lo)
|
||||
let fname = logDir </> show (pretty ha)
|
||||
|
||||
here <- liftIO $ doesFileExist fname
|
||||
|
||||
if here then do
|
||||
pure fname
|
||||
else do
|
||||
lock <- liftIO $ getLock locks lo
|
||||
MaybeT $ liftIO $ withMVar lock $ \_ -> do
|
||||
unpackObjects catApi lo dir
|
||||
here1 <- liftIO $ doesFileExist fname
|
||||
if here1 then do
|
||||
pure (Just fname)
|
||||
else do
|
||||
pure Nothing
|
||||
|
||||
maybe1 res (status status404) $ \r -> do
|
||||
addHeader "content-type" "application/octet-stream"
|
||||
file r
|
||||
|
||||
get "/:topic/HEAD" $ do
|
||||
repo <- fromString <$> param "topic"
|
||||
headRef <- liftIO $ do
|
||||
db <- liftIO $ makeDbPath repo >>= dbEnvReadOnly
|
||||
re <- withDB db stateGetActualRefs <&> headMay . sortOn guessHead . fmap (view _1)
|
||||
shutdownDB db
|
||||
pure re
|
||||
|
||||
case headRef of
|
||||
Nothing -> status status404
|
||||
Just hd -> do
|
||||
text [qc|ref: {show $ pretty $ hd}|]
|
||||
|
||||
cancel updater
|
||||
|
||||
where
|
||||
getLock locks k = modifyMVar locks $ \m -> do
|
||||
case HashMap.lookup k m of
|
||||
Just lock -> return (m, lock)
|
||||
Nothing -> do
|
||||
lock <- newMVar ()
|
||||
pure (HashMap.insert k lock m, lock)
|
||||
|
||||
|
||||
|
||||
-- TODO: hbs2-peer-http-api-reflog-fetch
|
||||
-- Ручка, что бы сделать reflog fetch
|
||||
|
||||
-- TODO: hbs2-peer-dyn-reflog-subscribe
|
||||
-- Возможность динамически подписываться на рефлоги
|
||||
|
||||
-- TODO: hbs2-peer-hook-on-reflog-update
|
||||
-- нужен хук, который даст возможность обрабатывать апдейты
|
||||
-- по нужному рефлогу. нужно много где
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
setLogging @DEBUG debugPrefix
|
||||
setLogging @INFO defLog
|
||||
setLogging @ERROR errorPrefix
|
||||
setLogging @WARN warnPrefix
|
||||
setLogging @NOTICE noticePrefix
|
||||
setLoggingOff @TRACE
|
||||
|
||||
-- TODO: hbs2-git-own-config
|
||||
|
||||
-- FIXME: port-number-to-config
|
||||
dumbHttpServe 4017
|
||||
|
||||
|
||||
|
||||
|
|
@ -72,11 +72,6 @@ capabilities :: BS.ByteString
|
|||
capabilities = BS.unlines ["push","fetch"]
|
||||
|
||||
|
||||
guessHead :: GitRef -> Integer
|
||||
guessHead = \case
|
||||
"refs/heads/master" -> 0
|
||||
"refs/heads/main" -> 0
|
||||
_ -> 1
|
||||
|
||||
loop :: forall m . ( MonadIO m
|
||||
, MonadCatch m
|
||||
|
|
|
|||
|
|
@ -8,12 +8,13 @@ import HBS2Git.State
|
|||
import HBS2Git.Config
|
||||
import HBS2Git.ListRefs
|
||||
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Data.Foldable
|
||||
import Prettyprinter.Render.Terminal
|
||||
|
||||
data ShowObject = ShowRef RepoRef | ShowConfig
|
||||
|
||||
showRef :: MonadIO m => RepoRef -> App m ()
|
||||
showRef :: (MonadIO m, MonadMask m) => RepoRef -> App m ()
|
||||
showRef h = do
|
||||
db <- makeDbPath h >>= dbEnv
|
||||
-- FIXME: re-implement-showRef
|
||||
|
|
@ -27,25 +28,25 @@ showRef h = do
|
|||
-- print $ pretty "last operations:"
|
||||
-- for_ imported (\(t,h1,h2) -> print $ pretty t <+> pretty h1 <+> pretty h2)
|
||||
|
||||
showRefs :: MonadIO m => App m ()
|
||||
showRefs :: (MonadIO m, MonadMask m) => App m ()
|
||||
showRefs = do
|
||||
liftIO $ putDoc $ line <> green "References:" <> section
|
||||
runListRefs
|
||||
|
||||
showConfig :: MonadIO m => App m ()
|
||||
showConfig :: (MonadIO m, MonadMask m) => App m ()
|
||||
showConfig = liftIO do
|
||||
ConfigPathInfo{..} <- getConfigPathInfo
|
||||
cfg <- readFile configFilePath
|
||||
putDoc $ green "Config file location:" <> section <> pretty configFilePath <> section
|
||||
putDoc $ green "Config contents:" <> line <> pretty cfg
|
||||
|
||||
showSummary :: MonadIO m => App m ()
|
||||
showSummary :: (MonadIO m, MonadMask m) => App m ()
|
||||
showSummary = do
|
||||
showRefs
|
||||
liftIO $ putDoc section
|
||||
showConfig
|
||||
|
||||
runShow :: MonadIO m => Maybe ShowObject -> App m ()
|
||||
runShow :: (MonadIO m, MonadMask m) => Maybe ShowObject -> App m ()
|
||||
runShow (Just (ShowRef h)) = showRef h
|
||||
runShow (Just ShowConfig) = showConfig
|
||||
runShow Nothing = showSummary
|
||||
|
|
|
|||
|
|
@ -173,3 +173,28 @@ executable git-remote-hbs2
|
|||
hs-source-dirs: git-hbs2
|
||||
default-language: Haskell2010
|
||||
|
||||
executable git-hbs2-http
|
||||
import: shared-properties
|
||||
main-is: GitHttpDumbMain.hs
|
||||
|
||||
ghc-options:
|
||||
-threaded
|
||||
-rtsopts
|
||||
"-with-rtsopts=-N4 -A64m -AL256m -I0"
|
||||
|
||||
other-modules:
|
||||
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
base, hbs2-git
|
||||
, http-types
|
||||
, optparse-applicative
|
||||
, scotty
|
||||
, wai-extra
|
||||
, warp
|
||||
, zlib
|
||||
|
||||
hs-source-dirs: git-hbs2-http
|
||||
default-language: Haskell2010
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -116,6 +116,11 @@ normalizeRef (GitRef x) = GitRef "refs/heads/" <> GitRef (fromMaybe x (Text.stri
|
|||
where
|
||||
strip = Text.dropWhile (=='+')
|
||||
|
||||
guessHead :: GitRef -> Integer
|
||||
guessHead = \case
|
||||
"refs/heads/master" -> 0
|
||||
"refs/heads/main" -> 0
|
||||
_ -> 1
|
||||
|
||||
shutUp :: MonadIO m => m ()
|
||||
shutUp = do
|
||||
|
|
|
|||
|
|
@ -241,7 +241,11 @@ writeBlockIO api bs = do
|
|||
readBlock :: forall m . (HasCatAPI m, MonadIO m) => HashRef -> m (Maybe ByteString)
|
||||
readBlock h = do
|
||||
req1 <- getHttpCatAPI
|
||||
let reqs = req1 <> "/" <> show (pretty h)
|
||||
readBlockFrom req1 h
|
||||
|
||||
readBlockFrom :: forall m . (MonadIO m) => API -> HashRef -> m (Maybe ByteString)
|
||||
readBlockFrom api h = do
|
||||
let reqs = api <> "/" <> show (pretty h)
|
||||
req <- liftIO $ parseRequest reqs
|
||||
resp <- httpLBS req
|
||||
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@ makeLenses 'ExportEnv
|
|||
|
||||
exportRefDeleted :: forall o m . ( MonadIO m
|
||||
, MonadCatch m
|
||||
-- , MonadMask m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, HasCatAPI m
|
||||
, HasConf m
|
||||
|
|
|
|||
|
|
@ -72,14 +72,87 @@ blockSource h = do
|
|||
|
||||
liftIO $ readTVarIO tsize <&> fromIntegral
|
||||
|
||||
getLogFlags :: MonadIO m
|
||||
=> (HashRef -> m (Maybe LBS.ByteString))
|
||||
-> HashRef
|
||||
-> m (Maybe [Text])
|
||||
|
||||
getLogFlags doRead h = do
|
||||
|
||||
runMaybeT do
|
||||
|
||||
treeBs <- MaybeT $ doRead h
|
||||
|
||||
let something = tryDetect (fromHashRef h) treeBs
|
||||
let meta = mconcat $ rights [ parseTop (Text.unpack s) | ShortMetadata s <- universeBi something ]
|
||||
|
||||
-- TODO: check-if-it-is-hbs2-git-log
|
||||
let tp = lastMay [ "hbs2-git-push-log"
|
||||
| (ListVal (Key "type:" [SymbolVal "hbs2-git-push-log"]) ) <- meta
|
||||
]
|
||||
|
||||
guard ( tp == Just "hbs2-git-push-log" )
|
||||
|
||||
pure $ mconcat [ Text.splitOn ":" (Text.pack (show $ pretty s))
|
||||
| (ListVal (Key "flags:" [SymbolVal s]) ) <- meta
|
||||
]
|
||||
|
||||
class HasImportOpts a where
|
||||
importForce :: a -> Bool
|
||||
importDontWriteGit :: a -> Bool
|
||||
|
||||
instance HasImportOpts Bool where
|
||||
importForce f = f
|
||||
importDontWriteGit = const False
|
||||
|
||||
instance HasImportOpts (Bool, Bool) where
|
||||
importForce = fst
|
||||
importDontWriteGit = snd
|
||||
|
||||
-- FIXME: ASAP-will-work-only-for-one-repo
|
||||
-- сейчас все транзакции помечаются, как обработанные
|
||||
-- в глобальном стейте для ссылки. таким образом,
|
||||
-- если мы вызвали для одного репозитория,
|
||||
-- то import не будет работать для остальных, т.к. решит,
|
||||
-- что всё обработано.
|
||||
--
|
||||
-- Решение:
|
||||
-- Вариант N1. Держать стейт локально в каждом
|
||||
-- каталоге git.
|
||||
-- Минусы:
|
||||
-- - большой оверхед по данным
|
||||
-- - мусор в каталоге git
|
||||
-- - например, git-hbs2-http вообще работает без "репозитория",
|
||||
-- как ему быть
|
||||
--
|
||||
-- Вариант N2. сделать развязку через какой-то ID
|
||||
-- репозитория или путь к нему.
|
||||
-- Минусы:
|
||||
-- - выглядит хрупко
|
||||
-- - например, git-hbs2-http вообще работает без "репозитория",
|
||||
-- как ему быть
|
||||
--
|
||||
-- Вариант N3. БД обновлять отдельно, объекты git - отдельно
|
||||
-- для каждого репозитория, запоминать (где?) проигранные для
|
||||
-- него логи.
|
||||
-- Минусы:
|
||||
-- - двойное сканирование файлов логов - получение, распаковка,
|
||||
-- сканирование и т.п. сначала для БД, потом для непосредственно
|
||||
-- репозитория
|
||||
--
|
||||
importRefLogNew :: ( MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadCatch m
|
||||
, MonadMask m
|
||||
, HasCatAPI m
|
||||
, HasImportOpts opts
|
||||
)
|
||||
=> Bool -> RepoRef -> m ()
|
||||
=> opts -> RepoRef -> m ()
|
||||
|
||||
importRefLogNew opts ref = runResourceT do
|
||||
|
||||
let force = importForce opts
|
||||
|
||||
importRefLogNew force ref = runResourceT do
|
||||
let myTempDir = "hbs-git"
|
||||
temp <- liftIO getCanonicalTemporaryDirectory
|
||||
(_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
|
||||
|
|
@ -232,6 +305,8 @@ importRefLogNew force ref = runResourceT do
|
|||
|
||||
_ -> pure ()
|
||||
|
||||
-- otherwise we wan't process those logs next time.
|
||||
unless (importDontWriteGit opts) do
|
||||
statePutLogImported h
|
||||
statePutTranImported e
|
||||
|
||||
|
|
@ -242,10 +317,10 @@ importRefLogNew force ref = runResourceT do
|
|||
statePutRefImported logRoot
|
||||
savepointRelease sp0
|
||||
|
||||
|
||||
where
|
||||
|
||||
writeIfNew gitHandle dir h (GitObject tp s) = do
|
||||
unless (importDontWriteGit opts) do
|
||||
let nf = dir </> show (pretty h)
|
||||
liftIO $ LBS.writeFile nf s
|
||||
hPutStrLn gitHandle nf
|
||||
|
|
|
|||
|
|
@ -73,14 +73,14 @@ runListRefs = do
|
|||
where
|
||||
isHbs2 (_, b) = Text.isPrefixOf hbs2Prefix b
|
||||
|
||||
runToolsScan :: (MonadUnliftIO m,MonadCatch m) => RepoRef -> App m ()
|
||||
runToolsScan :: (MonadUnliftIO m,MonadCatch m,MonadMask m) => RepoRef -> App m ()
|
||||
runToolsScan ref = do
|
||||
trace $ "runToolsScan" <+> pretty ref
|
||||
importRefLogNew False ref
|
||||
shutUp
|
||||
pure ()
|
||||
|
||||
runToolsGetRefs :: (MonadUnliftIO m,MonadCatch m) => RepoRef -> App m ()
|
||||
runToolsGetRefs :: (MonadUnliftIO m,MonadCatch m,MonadMask m) => RepoRef -> App m ()
|
||||
runToolsGetRefs ref = do
|
||||
db <- makeDbPath ref >>= dbEnv
|
||||
refs <- withDB db stateGetActualRefs
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
module HBS2Git.State where
|
||||
|
||||
import HBS2.Prelude
|
||||
import HBS2Git.Types
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Git.Types
|
||||
|
|
@ -7,6 +8,7 @@ import HBS2.Hash
|
|||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Function
|
||||
import Database.SQLite.Simple
|
||||
|
|
@ -27,6 +29,7 @@ import Control.Concurrent.STM
|
|||
import System.IO.Unsafe
|
||||
import Data.Graph (graphFromEdges, topSort)
|
||||
import Data.Map qualified as Map
|
||||
import Lens.Micro.Platform
|
||||
|
||||
-- FIXME: move-orphans-to-separate-module
|
||||
|
||||
|
|
@ -61,7 +64,7 @@ newtype DB m a =
|
|||
, Functor
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadReader Connection
|
||||
, MonadReader DBEnv
|
||||
, MonadTrans
|
||||
, MonadThrow
|
||||
, MonadCatch
|
||||
|
|
@ -71,32 +74,54 @@ instance (HasRefCredentials m) => HasRefCredentials (DB m) where
|
|||
getCredentials = lift . getCredentials
|
||||
setCredentials r s = lift (setCredentials r s)
|
||||
|
||||
dbConnTV :: TVar (Maybe DBEnv)
|
||||
dbConnTV = unsafePerformIO $ newTVarIO Nothing
|
||||
{-# NOINLINE dbConnTV #-}
|
||||
stateConnection :: MonadIO m => DB m Connection
|
||||
stateConnection = do
|
||||
env <- ask
|
||||
initConnection env
|
||||
|
||||
dbEnv :: MonadIO m => FilePath -> m DBEnv
|
||||
dbEnv fp = do
|
||||
initConnection :: MonadIO m => DBEnv -> m Connection
|
||||
initConnection env = do
|
||||
mco <- liftIO $ readTVarIO (view dbConn env)
|
||||
case mco of
|
||||
Just co -> pure co
|
||||
Nothing -> do
|
||||
co <- liftIO $ open (view dbFilePath env)
|
||||
liftIO $ atomically $ writeTVar (view dbConn env) (Just co)
|
||||
pure co
|
||||
|
||||
dbEnv0 :: (MonadIO m, MonadMask m) => DB m () -> FilePath -> m DBEnv
|
||||
dbEnv0 dbInit fp = do
|
||||
trace "dbEnv called"
|
||||
let dir = takeDirectory fp
|
||||
liftIO $ createDirectoryIfMissing True dir
|
||||
mbDb <- liftIO $ readTVarIO dbConnTV
|
||||
env <- DBEnv fp <$> liftIO (newTVarIO Nothing)
|
||||
void $ withDB env dbInit
|
||||
pure env
|
||||
|
||||
case mbDb of
|
||||
Nothing -> do
|
||||
co <- liftIO $ open fp
|
||||
liftIO $ atomically $ writeTVar dbConnTV (Just co)
|
||||
withDB co stateInit
|
||||
pure co
|
||||
dbEnv :: (MonadIO m, MonadMask m) => FilePath -> m DBEnv
|
||||
dbEnv = dbEnv0 stateInit
|
||||
|
||||
Just db -> pure db
|
||||
dbEnvReadOnly :: (MonadIO m, MonadMask m) => FilePath -> m DBEnv
|
||||
dbEnvReadOnly = dbEnv0 none
|
||||
|
||||
withDB :: DBEnv -> DB m a -> m a
|
||||
withDB env action = runReaderT (fromDB action) env
|
||||
withDB :: (MonadIO m, MonadMask m) => DBEnv -> DB m a -> m a
|
||||
withDB env action = do
|
||||
conn <- initConnection env
|
||||
finally (runReaderT (fromDB action) env) $ do
|
||||
-- NOTE: we could not close connection here.
|
||||
pure ()
|
||||
|
||||
shutdownDB :: MonadIO m => DBEnv -> m ()
|
||||
shutdownDB env = liftIO do
|
||||
co <- atomically do
|
||||
conn <- readTVar (view dbConn env)
|
||||
writeTVar (view dbConn env) Nothing
|
||||
pure conn
|
||||
maybe1 co none close
|
||||
|
||||
stateInit :: MonadIO m => DB m ()
|
||||
stateInit = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ execute_ conn [qc|
|
||||
create table if not exists logrefval
|
||||
( loghash text not null
|
||||
|
|
@ -203,17 +228,17 @@ savepointNew = do
|
|||
|
||||
savepointBegin :: forall m . MonadIO m => Savepoint -> DB m ()
|
||||
savepointBegin (Savepoint sp) = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ execute_ conn [qc|SAVEPOINT {sp}|]
|
||||
|
||||
savepointRelease:: forall m . MonadIO m => Savepoint -> DB m ()
|
||||
savepointRelease (Savepoint sp) = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ execute_ conn [qc|RELEASE SAVEPOINT {sp}|]
|
||||
|
||||
savepointRollback :: forall m . MonadIO m => Savepoint -> DB m ()
|
||||
savepointRollback (Savepoint sp) = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|]
|
||||
|
||||
transactional :: forall a m . (MonadCatch m, MonadIO m) => DB m a -> DB m a
|
||||
|
|
@ -242,7 +267,7 @@ transactional action = do
|
|||
|
||||
statePutLogRefVal :: MonadIO m => (HashRef, GitRef, GitHash) -> DB m ()
|
||||
statePutLogRefVal row = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ execute conn [qc|
|
||||
insert into logrefval (loghash,refname,refval) values(?,?,?)
|
||||
on conflict (loghash,refname) do nothing
|
||||
|
|
@ -251,7 +276,7 @@ statePutLogRefVal row = do
|
|||
|
||||
statePutLogObject :: MonadIO m => (HashRef, GitObjectType, GitHash) -> DB m ()
|
||||
statePutLogObject row = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ execute conn [qc|
|
||||
insert into logobject (loghash,type,githash) values(?,?,?)
|
||||
on conflict (loghash,githash) do nothing
|
||||
|
|
@ -259,14 +284,24 @@ statePutLogObject row = do
|
|||
|
||||
stateIsLogObjectExists :: MonadIO m => GitHash -> DB m Bool
|
||||
stateIsLogObjectExists h = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ query conn [qc|
|
||||
SELECT NULL FROM logobject WHERE githash = ? LIMIT 1
|
||||
|] (Only h) <&> isJust . listToMaybe . fmap (fromOnly @(Maybe Int))
|
||||
|
||||
|
||||
stateGetGitLogObject :: MonadIO m => GitHash -> DB m (Maybe HashRef)
|
||||
stateGetGitLogObject h = do
|
||||
conn <- stateConnection
|
||||
liftIO $ query conn [qc|
|
||||
SELECT loghash FROM logobject
|
||||
WHERE githash = ? and type in ('commit', 'tree', 'blob')
|
||||
LIMIT 1
|
||||
|] (Only h) <&> listToMaybe . fmap fromOnly
|
||||
|
||||
statePutLogContextCommit :: MonadIO m => HashRef -> GitHash -> DB m ()
|
||||
statePutLogContextCommit loghash ctx = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ execute conn [qc|
|
||||
insert into logobject (loghash,type,githash) values(?,'context',?)
|
||||
on conflict (loghash,githash) do nothing
|
||||
|
|
@ -274,7 +309,7 @@ statePutLogContextCommit loghash ctx = do
|
|||
|
||||
statePutLogCommitParent :: MonadIO m => (GitHash, GitHash) -> DB m ()
|
||||
statePutLogCommitParent row = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ execute conn [qc|
|
||||
insert into logcommitparent (kommit,parent) values(?,?)
|
||||
on conflict (kommit,parent) do nothing
|
||||
|
|
@ -283,7 +318,7 @@ statePutLogCommitParent row = do
|
|||
|
||||
statePutLogImported :: MonadIO m => HashRef -> DB m ()
|
||||
statePutLogImported h = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ execute conn [qc|
|
||||
insert into logimported (hash) values(?)
|
||||
on conflict (hash) do nothing
|
||||
|
|
@ -292,7 +327,7 @@ statePutLogImported h = do
|
|||
|
||||
stateGetLogImported :: MonadIO m => HashRef -> DB m Bool
|
||||
stateGetLogImported h = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
r <- liftIO $ query @_ @(Only Int) conn [qc|
|
||||
select 1 from logimported where hash = ? limit 1
|
||||
|] (Only h)
|
||||
|
|
@ -301,7 +336,7 @@ stateGetLogImported h = do
|
|||
|
||||
statePutRefImported :: MonadIO m => HashRef -> DB m ()
|
||||
statePutRefImported h = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ execute conn [qc|
|
||||
insert into refimported (hash) values(?)
|
||||
on conflict (hash) do nothing
|
||||
|
|
@ -309,7 +344,7 @@ statePutRefImported h = do
|
|||
|
||||
stateGetRefImported :: MonadIO m => HashRef -> DB m Bool
|
||||
stateGetRefImported h = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
r <- liftIO $ query @_ @(Only Int) conn [qc|
|
||||
select 1 from refimported where hash = ? limit 1
|
||||
|] (Only h)
|
||||
|
|
@ -317,7 +352,7 @@ stateGetRefImported h = do
|
|||
|
||||
statePutTranImported :: MonadIO m => HashRef -> DB m ()
|
||||
statePutTranImported h = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ execute conn [qc|
|
||||
insert into tranimported (hash) values(?)
|
||||
on conflict (hash) do nothing
|
||||
|
|
@ -325,7 +360,7 @@ statePutTranImported h = do
|
|||
|
||||
stateGetTranImported :: MonadIO m => HashRef -> DB m Bool
|
||||
stateGetTranImported h = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
r <- liftIO $ query @_ @(Only Int) conn [qc|
|
||||
select 1 from tranimported where hash = ? limit 1
|
||||
|] (Only h)
|
||||
|
|
@ -333,7 +368,7 @@ stateGetTranImported h = do
|
|||
|
||||
stateGetAllTranImported :: MonadIO m => DB m [HashRef]
|
||||
stateGetAllTranImported = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
results <- liftIO $ query_ conn [qc|
|
||||
select hash from tranimported
|
||||
|]
|
||||
|
|
@ -341,21 +376,21 @@ stateGetAllTranImported = do
|
|||
|
||||
stateGetImportedCommits :: MonadIO m => DB m [GitHash]
|
||||
stateGetImportedCommits = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ query_ conn [qc|
|
||||
select distinct(githash) from logobject where type = 'commit'
|
||||
|] <&> fmap fromOnly
|
||||
|
||||
stateGetActualRefs :: MonadIO m => DB m [(GitRef, GitHash)]
|
||||
stateGetActualRefs = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ query_ conn [qc|
|
||||
select refname,refval from v_refval_actual
|
||||
|]
|
||||
|
||||
stateGetActualRefValue :: MonadIO m => GitRef -> DB m (Maybe GitHash)
|
||||
stateGetActualRefValue ref = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ query conn [qc|
|
||||
select refval from v_refval_actual
|
||||
where refname = ?
|
||||
|
|
@ -363,14 +398,14 @@ stateGetActualRefValue ref = do
|
|||
|
||||
stateGetLastKnownCommits :: MonadIO m => Int -> DB m [GitHash]
|
||||
stateGetLastKnownCommits n = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
liftIO $ query conn [qc|
|
||||
select kommit from logcommitdepth order by depth asc limit ?;
|
||||
|] (Only n) <&> fmap fromOnly
|
||||
|
||||
stateUpdateCommitDepths :: MonadIO m => DB m ()
|
||||
stateUpdateCommitDepths = do
|
||||
conn <- ask
|
||||
conn <- stateConnection
|
||||
sp <- savepointNew
|
||||
|
||||
rows <- liftIO $ query_ @(GitHash, GitHash) conn [qc|SELECT kommit, parent FROM logcommitparent|]
|
||||
|
|
|
|||
|
|
@ -53,7 +53,12 @@ type HBS2L4Proto = L4Proto
|
|||
-- FIXME: introduce-API-type
|
||||
type API = String
|
||||
|
||||
type DBEnv = Connection
|
||||
data DBEnv =
|
||||
DBEnv { _dbFilePath :: FilePath
|
||||
, _dbConn :: TVar (Maybe Connection)
|
||||
}
|
||||
|
||||
makeLenses 'DBEnv
|
||||
|
||||
type RepoRef = RefLogKey Schema
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue