State.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# Language AllowAmbiguousTypes #-}
{-# Language UndecidableInstances #-}
{-# Language TemplateHaskell #-}
module HBS2Share.State
  ( module DBPipe.SQLite
  , withState
  , insertProcessed
  , isProcessed
  , updateReceived
  , updateMetaData
  , updateLocalDirEntry
  , selectLocalDirEntries
  , selectLocalHash
  , updateLocalDirEntryTime
  , selectLocalDirEntryTime
  , listLastReceived, listLastReceivedJSON
  , createReceivedTable
  , createMetaDataTable
  , createLocalDirTable
  , createProcessedTable
  , createRankTable
  , updateRank
  , updateTxRank
  , selectRank
  , selectBlockMeta
  , selectManifest
  , ReceivedEntry(..)
  ) where

import HBS2Share.Types
import HBS2Share.Dir.Types

import DBPipe.SQLite

import Data.Aeson as Aeson
import Data.Aeson.TH
import Data.Time
import Data.Text.Encoding (encodeUtf8)
import Text.InterpolatedString.Perl6 (qc)
import Data.ByteString.Lazy.Char8 as LBS
import Data.HashMap.Strict qualified as HashMap
import Data.List (sortOn)
import Data.List qualified as L
import Data.Set qualified as Set
import Data.Maybe
import System.FilePath (takeFileName)
import Lens.Micro.Platform hiding ((.=))
import Streaming.Prelude qualified as S

data ReceivedEntry =
  ReceivedEntry
  { receivedTx   :: HashRef
  , receivedHash :: HashRef
  , receivedSize :: Maybe Integer
  , receivedRank :: Maybe Int
  , receivedWhen :: UTCTime
  , receivedMeta :: Value
  }
  deriving stock (Show,Generic)

$(deriveJSON defaultOptions{fieldLabelModifier = stripLabelPrefix "received"} ''ReceivedEntry)


withState :: (MonadReader AppEnv m, MonadIO m)
          => DBPipeM m b
          -> m b

withState m = do
  d <- asks db
  withDB d m


createProcessedTable :: MonadIO m => DBPipeM m ()
createProcessedTable = do
  ddl [qc|
    create table if not exists processed
      (  hash       text not null
       , primary key (hash)
      )
      |]

createReceivedTable :: MonadIO m => DBPipeM m ()
createReceivedTable = do
  ddl [qc|
    create table if not exists received
      (  tx         text not null
       , ref        text not null
       , block      text not null
       , size       int
       , timestamp  datetime default current_timestamp
       , primary key (tx)
      )
      |]

createMetaDataTable :: MonadIO m => DBPipeM m ()
createMetaDataTable = do
  ddl [qc|
    create table if not exists metadata
      (  tx         text not null
       , attrname   text not null
       , attrval    text not null
       , primary key (tx,attrname)
      )
      |]

updateReceived :: (ToField a, MonadIO m)
               => a
               -> HashRef
               -> HashRef
               -> Maybe Integer
               -> DBPipeM m ()

updateReceived ref tx b s = do
  update [qc|
    insert into received(tx,ref,block,size) values(?,?,?,?)
    on conflict (tx) do nothing
    |] (tx,ref,b,s)

updateMetaData :: MonadIO m => HashRef -> PostMetaData -> DBPipeM m ()
updateMetaData tx (PostMetaData md) = do
  for_ (HashMap.toList md) $ \(k,v) -> do
    update [qc|
      insert into metadata (tx,attrname,attrval)
      values (?,?,?)
      on conflict (tx, attrname) do update set attrval = excluded.attrval
    |] (tx, k, LBS.unpack (Aeson.encode v))


instance FromRow ReceivedEntry where
  fromRow = ReceivedEntry
            <$> field
            <*> field
            <*> field
            <*> field
            <*> field
            <*> (mbJson =<< field @Text)

    where
      mbJson s =
        case Aeson.decode @Value . LBS.fromStrict . encodeUtf8 $ s of
             Just obj -> pure obj
             Nothing  -> pure Null

listLastReceived :: MonadIO m => Int -> MyRefChanId -> DBPipeM m [ReceivedEntry]
listLastReceived n rc =
  select [qc|
with o as (
  select r.tx
       , r.ref
       , r.block
       , r.size
       , t.rank
       , r.timestamp
  from received r left join txrank t on r.tx = t.tx
  where r.ref = ?
  order by t.rank desc nulls last, timestamp desc
  limit ?
  )
select o.tx
     , block
     , size
     , o.rank
     , timestamp
     , ( select json_group_object (m.attrname, json(m.attrval))
         from metadata m where m.tx = o.tx
       ) as meta
from o;
  |] (rc,n)


selectBlockMeta :: MonadIO m => HashRef -> DBPipeM m (Maybe ReceivedEntry)
selectBlockMeta href = do
  select [qc|

with o as (
  select r.tx
       , r.block
       , r.size
       , t.rank
       , r.timestamp

  from received r left join txrank t on r.tx = t.tx
  where r.tx = ?
  order by timestamp desc
  limit 1
  )
select o.tx
     , o.block
     , o.size
     , o.rank
     , timestamp
     , ( select json_group_object (m.attrname, json(m.attrval))
         from metadata m where m.tx = o.tx
       ) as meta
from o;
  |] (Only href) <&> listToMaybe


listLastReceivedJSON :: MonadIO m => Int -> MyRefChanId -> DBPipeM m [Value]
listLastReceivedJSON a b = do
  items <- listLastReceived a b <&> sortOn receivedWhen

  -- let wtf = [ fieldsOf x | x <- o ]
  now <- liftIO getCurrentTime
  tz <- liftIO getCurrentTimeZone

  for items $ \o -> do
    let lt = utcToLocalTime tz (receivedWhen o)
    let ago = diffUTCTime now (receivedWhen o)
    let agoSeconds = formatTime defaultTimeLocale "%s" ago & readMay @Int
    let agoHMS = formatTime defaultTimeLocale "%h:%M:%S" ago
    let ud = utctDay (receivedWhen o)
    let d = localDay lt

    let agoObj = case formatTime defaultTimeLocale "%D %H %M %S" ago & L.words of

                  [d,h,m,s] -> object [ "days"     .= readMay @Int d
                                      , "hours"    .= readMay @Int h
                                      , "minutes"  .= readMay @Int m
                                      , "seconds"  .= readMay @Int s
                                      , "secondsTotal" .= agoSeconds
                                      , "hms"      .= agoHMS
                                      ]

                  _         -> object []

    pure $ object [ "tx"   .= receivedTx o
                  , "hash" .= receivedHash o
                  , "utc"  .= receivedWhen o
                  , "utcTime"   .= formatTime defaultTimeLocale "%H:%M:%S" (receivedWhen o)
                  , "utcDate"   .= ud
                  , "localTime" .= formatTime defaultTimeLocale "%H:%M:%S" lt
                  , "localDate" .= d
                  , "ago"  .= agoObj
                  , "meta" .= receivedMeta o
                  ]

insertProcessed :: MonadIO m => HashRef -> DBPipeM m ()
insertProcessed href = do
    update [qc|
      insert into processed (hash)
      values (?)
      on conflict (hash) do nothing
    |] (Only href)

isProcessed :: MonadIO m => HashRef -> DBPipeM m Bool
isProcessed href = do
  select [qc|
    select 1
    from processed
    where hash = ?
    limit 1
    |] (Only href) <&> not . L.null . fmap (fromOnly @Int)


createLocalDirTable :: MonadIO m => DBPipeM m ()
createLocalDirTable = do

  ddl [qc|
    create table if not exists localdirentry
      ( lcookie     text not null
      , cookie      text not null
      , key         text not null
      , type        text not null
      , timestamp  datetime default current_timestamp
      , primary key (lcookie,key)
      )
      |]

  ddl [qc|
    create table if not exists localdirentryhash
      ( lcookie     text not null
      , key         text not null
      , hash        text
      , primary key (lcookie,key)
      )
  |]

  ddl [qc|
    create table if not exists localdirentrytime
      ( lcookie     text not null
      , key         text not null
      , modtime     datatime default current_timestamp
      , primary key (lcookie,key)
      )
  |]

deriving newtype instance ToField EntryKey
deriving newtype instance FromField EntryKey

updateLocalDirEntry :: (MonadIO m, MonadReader RunDirEnv m)
                    => Text     -- ^ cookie
                    -> EntryKey -- ^ entry key
                    -> Entry
                    -> DBPipeM m ()

updateLocalDirEntry c k e = do

  lc <- lift localCookie

  let tp = case e of
            EntryDir    -> "D"
            EntryFile{} -> "F"
            EntryTomb   -> "T"

  update [qc|
    insert into localdirentry (lcookie, cookie, key, type)
    values (?,?,?,?)
    on conflict (lcookie,key)
    do update
        set type      = excluded.type,
            timestamp = current_timestamp

  |] (lc, c, k, tp)


selectLocalDirEntries :: (MonadIO m, MonadReader RunDirEnv m)
                      => Maybe EntryKey
                      -> DBPipeM m [(EntryKey, Entry)]

selectLocalDirEntries k = do

  lc <- lift localCookie

  row <- select [qc|
                  select key, type
                  from localdirentry
                  where lcookie = ? and key = coalesce(?, key)
                |] (lc,k)

  S.toList_ do
    for_ row $ \(k :: EntryKey, t :: Text) -> do
      case t of
        "D" -> S.yield (k, EntryDir)
        "F" -> S.yield (k, EntryFile (File (takeFileName (fromEntryKey k))))
        "T" -> S.yield (k, EntryTomb)
        _   -> pure ()


selectLocalHash :: (MonadIO m, MonadReader RunDirEnv m)
                => EntryKey
                -> DBPipeM m (Maybe HashRef)

selectLocalHash k = do

  lc <- lift localCookie

  select [qc|
    select hash
    from localdirentryhash
    where lcookie = ? and key = ?
    |] (lc, k) <&> listToMaybe <&> fmap fromOnly


updateLocalDirEntryTime :: (MonadIO m, MonadReader RunDirEnv m)
                        => EntryKey -- ^ entry key
                        -> UTCTime
                        -> DBPipeM m ()

updateLocalDirEntryTime k t = do

  lc <- lift localCookie

  update [qc|
    insert into localdirentrytime (lcookie, key, modtime)
    values (?,?,?)
    on conflict (lcookie,key)
    do update
        set modtime = excluded.modtime
  |] (lc, k, t)


selectLocalDirEntryTime :: (MonadIO m, MonadReader RunDirEnv m)
                        => EntryKey -- ^ entry key
                        -> DBPipeM m (Maybe UTCTime)

selectLocalDirEntryTime k = do

  lc <- lift localCookie

  select [qc|
    select modtime from localdirentrytime t
    where
      t.lcookie = ? and t.key = ?
    limit 1
  |] (lc,k) <&> listToMaybe <&> fmap fromOnly


createRankTable :: MonadIO m => DBPipeM m ()
createRankTable = do
  ddl [qc|
    create table if not exists rank
    ( hash  text not null
    , rank  int not null
    , primary key (hash)
    )
  |]
  ddl [qc|
    create table if not exists txrank
    ( tx    text not null
    , rank  int not null
    , primary key (tx)
    )
  |]

updateRank :: MonadIO m => HashRef -> Int -> DBPipeM m ()
updateRank h r = do
  update [qc|
    insert into rank (hash,rank)
    values (?,?)
    on conflict (hash)
    do update
        set rank = excluded.rank
  |] (h, r)


updateTxRank :: MonadIO m => HashRef -> Int -> DBPipeM m ()
updateTxRank h r = do
  update [qc|
    insert into txrank (tx,rank)
    values (?,?)
    on conflict (tx)
    do update
        set rank = excluded.rank
  |] (h,r)


selectRank :: MonadIO m => HashRef -> DBPipeM m (Maybe Int)
selectRank h = do
  select [qc|
    select rank from rank
    where hash = ?
  |] (Only h) <&> fmap fromOnly . listToMaybe



  -- tombs as (
  --   SELECT * from s1
  --   WHERE s1.tp == 'T'
  --     AND NOT EXISTS (SELECT NULL FROM s1 WHERE tp <> 'T' AND rank > s1.rank
  -- )

  -- WITH s1 as (

  --   SELECT
  --       s0.block,
  --       coalesce(MAX(json_extract(s0.meta, '$."rank"')),0) AS rank,
  --       json_extract(s0.meta, '$."dir.entry.type"') AS tp,
  --       json_extract(s0.meta, '$."dir.entry.key"') AS key
  --   FROM (
  --       SELECT
  --           r.block,
  --           json_group_object(m.attrname, json(m.attrval)) AS meta
  --       FROM
  --           received r
  --       JOIN
  --           metadata m ON r.tx = m.tx
  --       GROUP BY
  --           r.tx
  --       HAVING json_extract(meta, '$."dir.cookie"') = ?
  --         AND json_extract(meta, '$."rank"')  > 0
  --   ) AS s0
  --   WHERE
  --       tp IN ('F', 'T', 'D')
  --   GROUP BY
  --       key

  -- )

  -- SELECT * from s1 WHERE s1.tp <> 'T'


selectManifest :: MonadIO m
               => Text -- ^ cookie
               -> DBPipeM m Manifest

selectManifest cookie = do
  let sql = [qc|

WITH s1 as (

  SELECT
      s0.block,
      coalesce(MAX(json_extract(s0.meta, '$."rank"')),0) AS rank,
      json_extract(s0.meta, '$."dir.entry.type"') AS tp,
      json_extract(s0.meta, '$."dir.entry.key"') AS key
  FROM (
      SELECT
          r.block,
          json_group_object(m.attrname, json(m.attrval)) AS meta
      FROM
          received r
      JOIN
          metadata m ON r.tx = m.tx
      GROUP BY
          r.tx
      HAVING json_extract(meta, '$."dir.cookie"') = ?
        AND json_extract(meta, '$."rank"')  > 0
  ) AS s0
  WHERE
      tp IN ('F', 'T', 'D')
  GROUP BY
      key

  )

  SELECT * FROM s1;

  |]

  rows <- select sql (Only cookie)

  let rt = [ r | (_,r,t,k) <- rows
           , t /= entryCode EntryTomb
           ] & Set.fromList

  items <- S.toList_ do
    for_ rows $ \(h :: HashRef, r :: Int, t :: Text, k :: EntryKey) -> do
      let entry' = case t of
                    "T" -> Just EntryTomb
                    "D" -> Just EntryDir
                    "F" -> Just $ EntryFile (File (takeFileName (fromEntryKey k)))
                    _   -> Nothing

      maybe1 entry' none $ \entry -> do
        S.yield (k, ManifestEntry entry r (Just h))

  pure $ Manifest (HashMap.fromList items)