From 233c1445b1f157b0c97ef5bf8782947b68152826 Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Fri, 6 Oct 2023 09:30:48 +0300
Subject: [PATCH] introducing cookie

---
 hbs2-git/lib/HBS2Git/Config.hs |  3 +++
 hbs2-git/lib/HBS2Git/Evolve.hs | 15 ++++++++++++
 hbs2-git/lib/HBS2Git/State.hs  | 45 ++++++++++++++++++++++++++++++----
 hbs2-git/lib/HBS2Git/Types.hs  | 17 ++++++++++++-
 4 files changed, 74 insertions(+), 6 deletions(-)

diff --git a/hbs2-git/lib/HBS2Git/Config.hs b/hbs2-git/lib/HBS2Git/Config.hs
index 1fe891fa..151504d5 100644
--- a/hbs2-git/lib/HBS2Git/Config.hs
+++ b/hbs2-git/lib/HBS2Git/Config.hs
@@ -87,3 +87,6 @@ configInit = liftIO do
   cfg <- readFile configFilePath <&> parseTop <&> either mempty id
   pure (configRepoParentDir, cfg)
 
+cookieFile :: MonadIO m => m FilePath
+cookieFile = configPath "" <&> (</> "cookie")
+
diff --git a/hbs2-git/lib/HBS2Git/Evolve.hs b/hbs2-git/lib/HBS2Git/Evolve.hs
index 1e7ebdfc..1e290826 100644
--- a/hbs2-git/lib/HBS2Git/Evolve.hs
+++ b/hbs2-git/lib/HBS2Git/Evolve.hs
@@ -26,12 +26,27 @@ evolve = do
   trace "DO EVOLVE"
 
   migrateConfig
+  generateCookie
 
   shutUp
 
   pure ()
 
 
+generateCookie :: MonadIO m => m ()
+generateCookie = void $ runMaybeT do
+  file <- cookieFile
+
+  guard =<< liftIO (not <$> doesFileExist file)
+
+  -- NOTE: cookie-note
+  --  поскольку куки должна быть уникальна в рамках БД,
+  --  а тут мы пока не знаем, с какой БД мы работаем,
+  --  то отложим генерацию куки до создания БД.
+  --  В скором времени БД будет одна, но пока это не так
+  liftIO $ writeFile file ""
+
+
 migrateConfig :: MonadIO m => m ()
 migrateConfig = void $ runMaybeT do
   here   <- liftIO getCurrentDirectory
diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs
index 1534b23d..a5a9a13a 100644
--- a/hbs2-git/lib/HBS2Git/State.hs
+++ b/hbs2-git/lib/HBS2Git/State.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module HBS2Git.State where
 
 import HBS2.Prelude
@@ -8,6 +9,8 @@ import HBS2.Hash
 
 import HBS2.System.Logger.Simple
 
+import HBS2Git.Config (cookieFile)
+
 import Control.Monad.Trans.Resource
 import Data.Functor
 import Data.Function
@@ -16,23 +19,21 @@ import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.ToField
 import Control.Monad.Reader
 import Text.InterpolatedString.Perl6 (qc)
-import Data.String
 import Data.ByteString.Lazy.Char8 qualified as LBS
 import System.Directory
 import System.FilePath
 import Data.Maybe
-import Data.Text (Text)
-import Prettyprinter
 import Data.UUID.V4 qualified as UUID
 import Control.Monad.Catch
 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
 
+instance ToField Cookie where
+  toField (Cookie lbs) = toField lbs
+
 instance ToField GitHash where
   toField h = toField (show $ pretty h)
 
@@ -191,6 +192,13 @@ stateInit = do
   );
   |]
 
+  liftIO $ execute_ conn [qc|
+  CREATE TABLE IF NOT EXISTS cookie
+  ( cookie text not null
+  , primary key (cookie)
+  );
+  |]
+
   liftIO $ execute_ conn [qc|
   DROP VIEW IF EXISTS v_log_depth;
   |]
@@ -222,6 +230,14 @@ stateInit = do
   ORDER BY r.refname;
   |]
 
+  cfn <- cookieFile
+  cf <- liftIO $ readFile cfn <&> take 4096
+
+  when (null cf) do
+    cookie <- stateGenCookie
+    liftIO $ LBS.writeFile cfn (fromCookie cookie)
+
+
 newtype Savepoint =
   Savepoint String
   deriving newtype (IsString)
@@ -445,3 +461,22 @@ stateUpdateCommitDepths = do
     pure ()
   savepointRelease sp
 
+
+stateGenCookie :: (MonadIO m) => DB m Cookie
+stateGenCookie = do
+  conn <- stateConnection
+  fix \next -> do
+    cookie <- liftIO (UUID.nextRandom <&> (fromString @Cookie. show))
+
+    here <- liftIO $ query conn [qc|select 1 from cookie where cookie = ? limit 1|] (Only cookie)
+                        <&> listToMaybe @(Only Int)
+
+    if isJust here then do
+      next
+    else liftIO do
+      void $ execute conn [qc|insert into cookie (cookie) values(?)|] (Only cookie)
+      pure cookie
+
+
+
+
diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs
index 5c0dd079..7a27c791 100644
--- a/hbs2-git/lib/HBS2Git/Types.hs
+++ b/hbs2-git/lib/HBS2Git/Types.hs
@@ -9,9 +9,11 @@ module HBS2Git.Types
   where
 
 import HBS2.Prelude.Plated
+import HBS2.Hash
+import HBS2.Base58
 import HBS2.Git.Types
 import HBS2.Net.Proto.RefLog (RefLogKey(..))
-import HBS2.Net.Proto.Types
+import HBS2.Net.Proto.Types hiding (Cookie)
 import HBS2.Net.Auth.Credentials
 
 import HBS2.System.Logger.Simple
@@ -24,6 +26,8 @@ import Control.Monad.Trans.Maybe
 import Control.Applicative
 import Control.Monad.IO.Class
 import Control.Monad.Reader
+import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Lazy.Char8 qualified as LBS
 import Database.SQLite.Simple (Connection)
 import Data.Char (isSpace)
 import Data.List qualified as List
@@ -53,6 +57,17 @@ data DBEnv =
         , _dbConn     :: TVar (Maybe Connection)
         }
 
+newtype Cookie =
+  Cookie { fromCookie :: ByteString }
+  deriving newtype (Eq,Ord,Show)
+
+instance IsString Cookie where
+  fromString s = Cookie cookie
+    where cookie = LBS.pack $ take 8
+                            $ show
+                            $ pretty
+                            $ hashObject @HbSync (LBS.pack s)
+
 makeLenses 'DBEnv
 
 type RepoRef = RefLogKey Schema