mirror of https://github.com/voidlizard/hbs2
533 lines
14 KiB
Haskell
533 lines
14 KiB
Haskell
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
|
||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||
module Fixme.State
|
||
( evolve
|
||
, withState
|
||
, insertFixme
|
||
, selectFixmeThin
|
||
, selectFixmeHash
|
||
, selectFixme
|
||
, deleteFixme
|
||
, insertCommit
|
||
, insertBlob
|
||
, selectObjectHash
|
||
, newCommit
|
||
, cleanupDatabase
|
||
, updateIndexes
|
||
, HasPredicate(..)
|
||
) 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.Aeson as Aeson
|
||
import Data.HashMap.Strict qualified as HM
|
||
import Text.InterpolatedString.Perl6 (qc)
|
||
import Data.Text qualified as Text
|
||
import Data.Maybe
|
||
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 System.TimeIt
|
||
|
||
|
||
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 = do
|
||
dbpath <- localDBPath
|
||
debug $ "evolve" <+> pretty dbpath
|
||
mkdir (takeDirectory dbpath)
|
||
|
||
db <- newDBPipeEnv dbPipeOptsDef dbpath
|
||
|
||
withDB db do
|
||
createTables
|
||
|
||
withState :: forall m a . (FixmePerks m, MonadReader FixmeEnv m) => DBPipeM m a -> m a
|
||
withState what = do
|
||
db <- asks fixmeEnvDb
|
||
withDB db what
|
||
|
||
|
||
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
|
||
|]
|
||
|
||
|
||
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)
|
||
|]
|
||
|
||
-- .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
|
||
|
||
mklist = List (noContext :: Context c)
|
||
mksym = Symbol (noContext :: Context c)
|
||
mkstr = Literal (noContext :: Context c) . LitStr
|
||
|
||
{- HLINT ignore "Functor law" -}
|
||
{- HLINT ignore "Eta reduce" -}
|
||
|
||
selectFixmeHash :: (FixmePerks m) => Text -> FixmeM m (Maybe Text)
|
||
selectFixmeHash what = withState do
|
||
|
||
let w = what <> "%"
|
||
|
||
r <- 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
|
||
|
||
|
||
let rs = listToMaybe r
|
||
-- catMaybes [ (x,) <$> Text.length . view _1 <$> Text.commonPrefixes what x
|
||
-- | x <- r ]
|
||
-- & sortBy (comparing (Down . snd))
|
||
-- & headMay
|
||
-- & fmap fst
|
||
-- debug $ red "selectFixmeHash" <+> pretty r <+> pretty rs
|
||
|
||
pure rs
|
||
|
||
|
||
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)
|
||
|
||
|
||
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(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
|
||
|]
|
||
|
||
|
||
selectFixmeThin :: (FixmePerks m, HasPredicate a) => a -> FixmeM m [FixmeThin]
|
||
selectFixmeThin a = withState do
|
||
|
||
let predic = genPredQ "j" (predicate a)
|
||
|
||
let sql = [qc|
|
||
|
||
select j.json as blob
|
||
|
||
from
|
||
fixmejson j join fixmeactual f on f.fixme = j.fixme
|
||
join fixme f0 on f0.id = f.fixme
|
||
|
||
where
|
||
|
||
(
|
||
{fst predic}
|
||
)
|
||
|
||
order by f0.ts asc nulls first
|
||
|
||
|]
|
||
|
||
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|]
|
||
|
||
deleteFixme :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
|
||
deleteFixme hash = withState do
|
||
trace $ red "deleteFixme" <+> pretty hash
|
||
insert [qc| insert into fixmedeleted (id,ts,deleted)
|
||
values (?,(strftime('%s', 'now')),true)
|
||
on conflict(id,ts) do nothing
|
||
|] (Only hash)
|
||
|
||
|
||
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
|
||
|
||
|