mirror of https://github.com/voidlizard/hbs2
708 lines
20 KiB
Haskell
708 lines
20 KiB
Haskell
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
|
||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||
module Fixme.State
|
||
( evolve
|
||
, withState
|
||
, insertFixme
|
||
, selectFixmeThin
|
||
, selectFixmeHash
|
||
, selectFixmeHashes
|
||
, selectFixme
|
||
, deleteFixme
|
||
, updateFixme
|
||
, insertCommit
|
||
, insertBlob
|
||
, selectObjectHash
|
||
, newCommit
|
||
, cleanupDatabase
|
||
, updateIndexes
|
||
, insertFixmeDelStaged
|
||
, insertFixmeModStaged
|
||
, selectStageModified
|
||
, selectStageDeleted
|
||
, selectStage
|
||
, cleanStage
|
||
, insertProcessed
|
||
, isProcessed
|
||
, selectProcessed
|
||
, checkFixmeExists
|
||
, listAllFixmeHashes
|
||
, HasPredicate(..)
|
||
, SelectPredicate(..)
|
||
) where
|
||
|
||
import Fixme.Prelude
|
||
import Fixme.Types
|
||
import Fixme.Config
|
||
|
||
import HBS2.System.Dir
|
||
import Data.Config.Suckless
|
||
import Data.Config.Suckless.Syntax
|
||
import DBPipe.SQLite hiding (field)
|
||
|
||
import Data.HashSet (HashSet)
|
||
import Data.HashSet qualified as HS
|
||
import Data.Aeson as Aeson
|
||
import Data.HashMap.Strict qualified as HM
|
||
import Text.InterpolatedString.Perl6 (q,qc)
|
||
import Data.Text qualified as Text
|
||
import Data.Maybe
|
||
import Data.List qualified as List
|
||
import Data.Either
|
||
import Data.List (sortBy,sortOn)
|
||
import Data.Ord
|
||
import Lens.Micro.Platform
|
||
import Data.Generics.Product.Fields (field)
|
||
import Control.Monad.Trans.Maybe
|
||
import Data.Coerce
|
||
import Data.Fixed
|
||
import Data.Word (Word64)
|
||
import System.TimeIt
|
||
|
||
-- TODO: runPipe-omitted
|
||
-- runPipe нигде не запускается, значит, все изменения
|
||
-- будут закоммичены в БД только по явному вызову
|
||
-- commitAll или transactional
|
||
-- это может объясняеть некоторые артефакты.
|
||
-- Но это и удобно: кажется, что можно менять БД
|
||
-- на лету бесплатно
|
||
|
||
|
||
pattern Operand :: forall {c} . Text -> Syntax c
|
||
pattern Operand what <- (operand -> Just what)
|
||
|
||
pattern BinOp :: forall {c} . Id -> Syntax c
|
||
pattern BinOp what <- (binOp -> Just what)
|
||
|
||
binOp :: Syntax c -> Maybe Id
|
||
binOp = \case
|
||
SymbolVal "~" -> Just "like"
|
||
SymbolVal "&&" -> Just "and"
|
||
SymbolVal "||" -> Just "or"
|
||
_ -> Nothing
|
||
|
||
operand :: Syntax c -> Maybe Text
|
||
operand = \case
|
||
SymbolVal c -> Just (coerce c)
|
||
LitStrVal s -> Just s
|
||
LitIntVal i -> Just (Text.pack (show i))
|
||
LitScientificVal v -> Just (Text.pack (show v))
|
||
_ -> Nothing
|
||
|
||
|
||
instance ToField HashRef where
|
||
toField x = toField $ show $ pretty x
|
||
|
||
instance FromField HashRef where
|
||
fromField = fmap (fromString @HashRef) . fromField @String
|
||
|
||
evolve :: FixmePerks m => FixmeM m ()
|
||
evolve = withState do
|
||
createTables
|
||
|
||
withState :: forall m a . (FixmePerks m, MonadReader FixmeEnv m) => DBPipeM m a -> m a
|
||
withState what = do
|
||
lock <- asks fixmeLock
|
||
db <- withMVar lock $ \_ -> do
|
||
t <- asks fixmeEnvDb
|
||
mdb <- readTVarIO t
|
||
case mdb of
|
||
Just d -> pure (Right d)
|
||
Nothing -> do
|
||
path <- asks fixmeEnvDbPath >>= readTVarIO
|
||
newDb <- try @_ @IOException (newDBPipeEnv dbPipeOptsDef path)
|
||
case newDb of
|
||
Left e -> pure (Left e)
|
||
Right db -> do
|
||
debug "set-new-db"
|
||
atomically $ writeTVar t (Just db)
|
||
pure $ Right db
|
||
|
||
either throwIO (`withDB` what) db
|
||
|
||
createTables :: FixmePerks m => DBPipeM m ()
|
||
createTables = do
|
||
|
||
-- тут все таблицы будут называться с префиксом
|
||
-- fixme, что бы может быть можно было встроить
|
||
-- в другую бд, если вдруг понадобится
|
||
|
||
ddl [qc|
|
||
create table if not exists fixmegitobject
|
||
( hash text not null
|
||
, type text null
|
||
, primary key (hash)
|
||
)
|
||
|]
|
||
|
||
ddl [qc|
|
||
create table if not exists fixme
|
||
( id text not null
|
||
, ts integer
|
||
, fixme blob not null
|
||
, primary key (id)
|
||
)
|
||
|]
|
||
|
||
ddl [qc|
|
||
create table if not exists fixmedeleted
|
||
( id text not null
|
||
, ts integer not null
|
||
, deleted bool not null
|
||
, primary key (id,ts)
|
||
)
|
||
|]
|
||
|
||
ddl [qc|
|
||
create table if not exists fixmerel
|
||
( origin text not null
|
||
, related text not null
|
||
, ts integer not null
|
||
, reason text not null
|
||
, primary key (origin,related,ts)
|
||
)
|
||
|]
|
||
|
||
ddl [qc|
|
||
create table if not exists fixmeattr
|
||
( fixme text not null
|
||
, ts integer null
|
||
, name text not null
|
||
, value text
|
||
, primary key (fixme,ts,name)
|
||
)
|
||
|]
|
||
|
||
ddl [qc| drop view if exists fixmeattrview |]
|
||
|
||
let commits = [qc|name in ('commit','committer','committer-name','committer-email','commit-time')|] :: Text
|
||
|
||
ddl [qc|
|
||
create view fixmeattrview as
|
||
with ranked1 as (
|
||
select
|
||
fixme,
|
||
name,
|
||
value,
|
||
row_number() over (partition by fixme, name order by ts desc nulls first) as rn
|
||
from fixmeattr
|
||
where not ({commits})
|
||
)
|
||
, ranked2 as (
|
||
select
|
||
fixme,
|
||
name,
|
||
value,
|
||
row_number() over (partition by fixme, name order by ts asc nulls last) as rn
|
||
from fixmeattr
|
||
where ({commits})
|
||
)
|
||
|
||
select distinct fixme,name,value
|
||
from
|
||
(
|
||
select
|
||
fixme,
|
||
name,
|
||
value
|
||
from ranked1
|
||
where rn = 1
|
||
|
||
union
|
||
|
||
select
|
||
fixme,
|
||
name,
|
||
value
|
||
from ranked2
|
||
where rn = 1
|
||
)
|
||
|]
|
||
|
||
ddl [qc|drop view if exists fixmeactualview|]
|
||
|
||
ddl [qc|
|
||
create view fixmeactualview as
|
||
with a1 as (
|
||
select
|
||
a.fixme,
|
||
f.ts,
|
||
a.name,
|
||
a.value
|
||
from
|
||
fixmeattrview a
|
||
join fixme f on a.fixme = f.id
|
||
where
|
||
a.name = 'fixme-key'
|
||
and not exists (select null from fixmedeleted d where d.id = f.id)
|
||
),
|
||
rn AS (
|
||
select
|
||
f.id,
|
||
f.ts,
|
||
a.value AS fixmekey,
|
||
row_number() over (partition by a.value order by f.ts desc) as rn
|
||
from
|
||
fixme f
|
||
join a1 a on f.id = a.fixme and a.name = 'fixme-key'
|
||
)
|
||
select id as fixme, fixmekey, ts from rn
|
||
where rn = 1
|
||
and not exists (
|
||
select null
|
||
from fixmeattr a
|
||
join fixmedeleted d on d.id = a.fixme
|
||
where a.name = 'fixme-key'
|
||
and a.value = rn.fixmekey
|
||
)
|
||
|
||
|]
|
||
|
||
|
||
ddl [qc|
|
||
create table if not exists fixmeactual
|
||
( fixme text not null
|
||
, primary key (fixme)
|
||
)
|
||
|]
|
||
|
||
ddl [qc|
|
||
create table if not exists fixmejson
|
||
( fixme text not null
|
||
, fixmekey text
|
||
, json blob
|
||
, primary key (fixme)
|
||
)
|
||
|]
|
||
|
||
ddl [qc|
|
||
create index if not exists idx_fixmekey ON fixmejson(fixmekey)
|
||
|]
|
||
|
||
ddl [qc| create table if not exists fixmestagedel
|
||
( hash text not null primary key
|
||
, ts integer not null
|
||
)
|
||
|]
|
||
|
||
ddl [qc| create table if not exists fixmestagemod
|
||
( hash text not null
|
||
, ts integer not null
|
||
, attr text not null
|
||
, value text
|
||
, primary key (hash,attr)
|
||
)
|
||
|]
|
||
|
||
ddl [qc| create table if not exists fixmeprocessed
|
||
( hash text not null
|
||
, primary key (hash)
|
||
)
|
||
|]
|
||
|
||
-- .fixme-new/state.db
|
||
-- and not exists (select null from fixmedeleted d where a.fixme = id limit 1)
|
||
|
||
insertCommit :: FixmePerks m => GitHash -> DBPipeM m ()
|
||
insertCommit gh = do
|
||
insert [qc|
|
||
insert into fixmegitobject (hash,type) values(?,'commit')
|
||
on conflict (hash) do nothing
|
||
|] (Only gh)
|
||
|
||
insertBlob :: FixmePerks m => GitHash -> DBPipeM m ()
|
||
insertBlob gh = do
|
||
insert [qc|
|
||
insert into fixmegitobject (hash,type) values(?,'blob')
|
||
on conflict (hash) do nothing
|
||
|] (Only gh)
|
||
|
||
selectObjectHash :: FixmePerks m => GitHash -> DBPipeM m (Maybe GitHash)
|
||
selectObjectHash gh = do
|
||
select [qc|select hash from fixmegitobject where hash = ?|] (Only gh)
|
||
<&> fmap fromOnly . listToMaybe
|
||
|
||
newCommit :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m Bool
|
||
newCommit gh = isNothing <$> withState (selectObjectHash gh)
|
||
|
||
insertFixme :: FixmePerks m => Fixme -> DBPipeM m ()
|
||
insertFixme fx@Fixme{..} = do
|
||
let fixme = serialise fx
|
||
let fxId = hashObject @HbSync fixme & HashRef
|
||
insert [qc|insert into fixme (id, ts, fixme) values (?,?,?)
|
||
on conflict(id) do nothing
|
||
|] (fxId, fixmeTs, fixme)
|
||
|
||
for_ (HM.toList fixmeAttr) $ \(n,v) -> do
|
||
insert [qc|
|
||
insert into fixmeattr(fixme,ts,name,value)
|
||
values (?,?,?,?)
|
||
on conflict (fixme,ts,name) do update set value = excluded.value
|
||
|] (fxId, fixmeTs, n, v)
|
||
|
||
insert [qc|
|
||
insert into fixmeattr(fixme,ts,name,value)
|
||
values (?,?,?,?)
|
||
on conflict (fixme,ts,name) do update set value = excluded.value
|
||
|] (fxId, fixmeTs, "fixme-tag", fixmeTag)
|
||
|
||
insert [qc|
|
||
insert into fixmeattr(fixme,ts,name,value)
|
||
values (?,?,?,?)
|
||
on conflict (fixme,ts,name) do update set value = excluded.value
|
||
|] (fxId, fixmeTs, "fixme-title", fixmeTitle)
|
||
|
||
|
||
data SelectPredicate =
|
||
All
|
||
| FixmeHashExactly Text
|
||
| AttrLike Text Text
|
||
| And SelectPredicate SelectPredicate
|
||
| Or SelectPredicate SelectPredicate
|
||
| Not SelectPredicate
|
||
| Ignored
|
||
deriving stock (Data,Generic,Show)
|
||
|
||
class HasPredicate a where
|
||
predicate :: a -> SelectPredicate
|
||
|
||
instance HasPredicate () where
|
||
predicate = const All
|
||
|
||
instance HasPredicate SelectPredicate where
|
||
predicate = id
|
||
|
||
|
||
instance IsContext c => HasPredicate [Syntax c] where
|
||
predicate s = goPred $ unlist $ go s
|
||
where
|
||
|
||
goPred :: Syntax c -> SelectPredicate
|
||
goPred = \case
|
||
ListVal [SymbolVal "not", a] -> Not (goPred a)
|
||
ListVal [SymbolVal "or", a, b] -> Or (goPred a) (goPred b)
|
||
ListVal [SymbolVal "and", a, b] -> And (goPred a) (goPred b)
|
||
ListVal [SymbolVal "like", StringLike a, StringLike b] -> AttrLike (Text.pack a) (Text.pack b)
|
||
_ -> Ignored
|
||
|
||
go :: [Syntax c] -> Syntax c
|
||
go = \case
|
||
|
||
( SymbolVal "!" : rest ) -> do
|
||
mklist [mksym "not", unlist (go rest)]
|
||
|
||
( Operand a : SymbolVal "~" : Operand b : rest ) -> do
|
||
go (mklist [mksym "like", mkstr a, mkstr b] : rest)
|
||
|
||
( w : SymbolVal "&&" : rest ) -> do
|
||
mklist [mksym "and", unlist w, unlist (go rest)]
|
||
|
||
( w : SymbolVal "||" : rest ) -> do
|
||
mklist [mksym "or", unlist w, unlist (go rest)]
|
||
|
||
w -> mklist w
|
||
|
||
unlist = \case
|
||
ListVal [x] -> x
|
||
x -> x
|
||
|
||
|
||
{- HLINT ignore "Functor law" -}
|
||
{- HLINT ignore "Eta reduce" -}
|
||
|
||
selectFixmeHash :: (FixmePerks m) => Text -> FixmeM m (Maybe Text)
|
||
selectFixmeHash what = listToMaybe <$> selectFixmeHashes what
|
||
|
||
selectFixmeHashes :: (FixmePerks m) => Text -> FixmeM m [Text]
|
||
selectFixmeHashes what = withState do
|
||
let w = what <> "%"
|
||
select @(Only Text)
|
||
[qc| select fixme
|
||
from fixmejson
|
||
where json_extract(json,'$."fixme-key"') like ?
|
||
union
|
||
select id
|
||
from fixme
|
||
where id like ?
|
||
|] (w,w)
|
||
<&> fmap fromOnly
|
||
|
||
selectFixme :: FixmePerks m => Text -> FixmeM m (Maybe Fixme)
|
||
selectFixme txt = do
|
||
|
||
attrs <- selectFixmeThin (FixmeHashExactly txt)
|
||
<&> fmap coerce . headMay
|
||
<&> fromMaybe mempty
|
||
|
||
runMaybeT do
|
||
|
||
lift (withState $ select [qc|select fixme from fixme where id = ? limit 1|] (Only txt))
|
||
<&> listToMaybe . fmap fromOnly
|
||
>>= toMPlus
|
||
<&> (deserialiseOrFail @Fixme)
|
||
>>= toMPlus
|
||
<&> over (field @"fixmeAttr") (<> attrs)
|
||
|
||
|
||
listAllFixmeHashes :: (FixmePerks m, MonadReader FixmeEnv m) => m (HashSet HashRef)
|
||
listAllFixmeHashes = withState do
|
||
select_ @_ @(Only HashRef) [qc|select id from fixme|]
|
||
<&> HS.fromList . fmap fromOnly
|
||
|
||
checkFixmeExists :: FixmePerks m => HashRef -> FixmeM m Bool
|
||
checkFixmeExists what = withState do
|
||
select @(Only (Maybe Int)) [qc|select 1 from fixme where id = ? limit 1|] (Only what)
|
||
<&> not . List.null
|
||
|
||
data Bound = forall a . (ToField a, Show a) => Bound a
|
||
|
||
instance ToField Bound where
|
||
toField (Bound x) = toField x
|
||
|
||
instance Show Bound where
|
||
show (Bound x) = show x
|
||
|
||
genPredQ :: Text -> SelectPredicate -> (Text, [Bound])
|
||
genPredQ tbl what = go what
|
||
where
|
||
go = \case
|
||
All -> ("true", mempty)
|
||
|
||
FixmeHashExactly x ->
|
||
([qc|({tbl}.fixme = ?)|], [Bound x])
|
||
|
||
AttrLike "fixme-hash" val -> do
|
||
let binds = [Bound (val <> "%")]
|
||
([qc|({tbl}.fixme like ?)|], binds)
|
||
|
||
AttrLike name val -> do
|
||
let x = val <> "%"
|
||
let binds = [Bound x]
|
||
([qc|(json_extract({tbl}.json, '$."{name}"') like ?)|], binds)
|
||
|
||
Not a -> do
|
||
let (sql, bound) = go a
|
||
([qc|(coalesce(not {sql},true))|], bound)
|
||
|
||
And a b -> do
|
||
let (asql, abound) = go a
|
||
let (bsql, bbound) = go b
|
||
([qc|{asql} and {bsql}|], abound <> bbound)
|
||
|
||
Or a b -> do
|
||
let asql = go a
|
||
let bsql = go b
|
||
([qc|{fst asql} or {fst bsql}|], snd asql <> snd bsql)
|
||
|
||
Ignored -> ("false", mempty)
|
||
|
||
|
||
updateFixmeJson :: FixmePerks m => DBPipeM m ()
|
||
updateFixmeJson = do
|
||
|
||
update_ [qc|
|
||
|
||
insert into fixmejson (fixme,fixmekey,json)
|
||
with json as (
|
||
select
|
||
a.fixme as fixme,
|
||
cast(json_set(json_group_object(a.name,a.value), '$."fixme-hash"', f.fixme) as blob) as json
|
||
|
||
from
|
||
fixmeattrview a join fixmeactual f on f.fixme = a.fixme
|
||
|
||
group by a.fixme
|
||
)
|
||
|
||
select
|
||
fixme
|
||
, json_extract(json, '$."fixme-key"') as fixmekey
|
||
, json
|
||
from json where true
|
||
on conflict (fixme) do update set json = excluded.json, fixmekey = excluded.fixmekey
|
||
|]
|
||
|
||
|
||
-- TODO: predicate-for-stage-toggle
|
||
selectFixmeThin :: (FixmePerks m, HasPredicate a) => a -> FixmeM m [FixmeThin]
|
||
selectFixmeThin a = withState do
|
||
|
||
let predic = genPredQ "j" (predicate a)
|
||
|
||
let emptyObect = [q|'{}'|] :: String
|
||
|
||
let sql = [qc|
|
||
|
||
with s1 as (
|
||
select m.hash as hash
|
||
, cast(json_group_object(m.attr,m.value) as blob) as json
|
||
from fixmestagemod m
|
||
)
|
||
|
||
select cast(json_patch(j.json, coalesce(s.json,{emptyObect})) as blob) as blob
|
||
|
||
from
|
||
fixmejson j join fixmeactual f on f.fixme = j.fixme
|
||
join fixme f0 on f0.id = f.fixme
|
||
left join s1 s on s.hash = j.fixme
|
||
|
||
where
|
||
|
||
(
|
||
{fst predic}
|
||
)
|
||
|
||
order by json_extract(blob, '$.commit-time'), json_extract(blob, '$.title')
|
||
|
||
|]
|
||
|
||
trace $ red "selectFixmeThin" <> line <> pretty sql
|
||
|
||
(t,r) <- timeItT $ select sql (snd predic) <&> mapMaybe (Aeson.decode @FixmeThin . fromOnly)
|
||
|
||
trace $ yellow "selectFixmeThin" <> line
|
||
<> pretty sql <> line
|
||
<> pretty (length r) <+> "rows" <> line
|
||
<> pretty "elapsed" <+> pretty (realToFrac t :: Fixed E6)
|
||
|
||
pure r
|
||
|
||
cleanupDatabase :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
|
||
cleanupDatabase = do
|
||
warn $ red "cleanupDatabase"
|
||
withState $ transactional do
|
||
update_ [qc|delete from fixme|]
|
||
update_ [qc|delete from fixmeattr|]
|
||
update_ [qc|delete from fixmegitobject|]
|
||
update_ [qc|delete from fixmedeleted|]
|
||
update_ [qc|delete from fixmerel|]
|
||
update_ [qc|delete from fixmeactual|]
|
||
update_ [qc|delete from fixmejson|]
|
||
update_ [qc|delete from fixmestagedel|]
|
||
update_ [qc|delete from fixmestagemod|]
|
||
|
||
|
||
insertFixmeModStaged :: (FixmePerks m,MonadReader FixmeEnv m)
|
||
=> Text
|
||
-> FixmeAttrName
|
||
-> FixmeAttrVal
|
||
-> m ()
|
||
insertFixmeModStaged hash k v = withState do
|
||
ts <- getEpoch
|
||
insert [qc| insert into fixmestagemod (hash,ts,attr,value) values(?,?,?,?)
|
||
on conflict (hash,attr)
|
||
do update set hash = excluded.hash
|
||
, ts = excluded.ts
|
||
, attr = excluded.attr
|
||
, value = excluded.value
|
||
|] (hash,ts,k,v)
|
||
|
||
|
||
insertFixmeDelStaged :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
|
||
insertFixmeDelStaged hash = withState do
|
||
ts <- getEpoch
|
||
insert [qc| insert into fixmestagedel (hash,ts) values(?,?)
|
||
on conflict (hash)
|
||
do update set hash = excluded.hash
|
||
, ts = excluded.ts
|
||
|] (hash,ts)
|
||
|
||
|
||
type StageModRow = (HashRef,Word64,Text,Text)
|
||
|
||
selectStageModified :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
|
||
selectStageModified = withState do
|
||
what <- select_ @_ @StageModRow [qc|select hash,ts,attr,value from fixmestagemod|]
|
||
for what $ \(h,t,k,v) -> do
|
||
pure $ Modified t h (FixmeAttrName k) (FixmeAttrVal v)
|
||
|
||
selectStageDeleted :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
|
||
selectStageDeleted = withState do
|
||
what <- select_ @_ @(HashRef,Word64) [qc|select hash,ts from fixmestagedel|]
|
||
for what $ \(h,t) -> do
|
||
pure $ Deleted t h
|
||
|
||
selectStage :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
|
||
selectStage = do
|
||
a <- selectStageModified
|
||
b <- selectStageDeleted
|
||
pure (a<>b)
|
||
|
||
cleanStage :: (FixmePerks m,MonadReader FixmeEnv m) => m ()
|
||
cleanStage = withState do
|
||
transactional do
|
||
update_ [qc|delete from fixmestagedel|]
|
||
update_ [qc|delete from fixmestagemod|]
|
||
|
||
deleteFixme :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
|
||
deleteFixme hash = withState do
|
||
trace $ red "deleteFixme" <+> pretty hash
|
||
|
||
here <- select [qc| select true
|
||
from fixmedeleted
|
||
where deleted and id = ?
|
||
order by ts desc
|
||
limit 1
|
||
|] (Only hash) <&> isJust . listToMaybe . fmap (fromOnly @Bool)
|
||
|
||
unless here do
|
||
insert [qc| insert into fixmedeleted (id,ts,deleted)
|
||
values (?,(strftime('%s', 'now')),true)
|
||
on conflict(id,ts) do nothing
|
||
|] (Only hash)
|
||
|
||
updateFixme :: (FixmePerks m,MonadReader FixmeEnv m)
|
||
=> Maybe FixmeTimestamp
|
||
-> Text
|
||
-> FixmeAttrName
|
||
-> FixmeAttrVal
|
||
-> m ()
|
||
|
||
updateFixme ts hash a b = withState do
|
||
warn $ red "updateFixme" <+> pretty hash
|
||
insert [qc| insert into fixmeattr (fixme,ts,name,value)
|
||
values (?,coalesce(?,strftime('%s', 'now')),?,?)
|
||
on conflict(fixme,ts,name) do update set value = excluded.value
|
||
|] (hash,ts,a,b)
|
||
|
||
updateIndexes :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
|
||
updateIndexes = withState $ transactional do
|
||
update_ [qc|delete from fixmeactual|]
|
||
update_ [qc|
|
||
insert into fixmeactual
|
||
select distinct fixme from fixmeactualview
|
||
|]
|
||
updateFixmeJson
|
||
-- FIXME: delete-table-grows
|
||
-- надо добавлять статус в fixmedeleted
|
||
-- только если он отличается от последнего
|
||
-- известного статуса
|
||
update_ [qc|delete from fixmejson where fixme in (select distinct id from fixmedeleted)|]
|
||
|
||
|
||
|
||
insertProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w)
|
||
=> w
|
||
-> DBPipeM m ()
|
||
insertProcessed what = do
|
||
insert [qc| insert into fixmeprocessed (hash) values(?)
|
||
on conflict (hash) do nothing
|
||
|] (Only (show $ pretty $ hashObject @HbSync what))
|
||
|
||
|
||
isProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w)
|
||
=> w
|
||
-> DBPipeM m Bool
|
||
isProcessed what = do
|
||
let k = show $ pretty $ hashObject @HbSync what
|
||
select @(Only (Maybe Int)) [qc| select null from fixmeprocessed where hash = ? limit 1 |] (Only k)
|
||
<&> isJust . listToMaybe
|
||
|
||
selectProcessed :: (FixmePerks m, MonadReader FixmeEnv m)
|
||
=> m [HashRef]
|
||
selectProcessed = withState do
|
||
select_ [qc|select hash from fixmeprocessed|]
|
||
<&> fmap fromOnly
|
||
|
||
|