From 29b71fc21654081d4c1e6586db1eedeaacdea38e Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Fri, 1 Jan 2021 09:04:48 +0200
Subject: [PATCH] Fingerprint the 'Buuka' and use it as context

---
 buuka.cabal            |  1 +
 default.nix            |  6 +++---
 src/Data/Buuka.hs      | 23 ++++++++++++++++++++---
 src/Operations/List.hs | 19 +++++++++++--------
 4 files changed, 35 insertions(+), 14 deletions(-)

diff --git a/buuka.cabal b/buuka.cabal
index 3b6e41c..4e63cbe 100644
--- a/buuka.cabal
+++ b/buuka.cabal
@@ -55,6 +55,7 @@ library
                      , hashids
                      , text
                      , lens
+                     , hashable
   hs-source-dirs:      src
 
 executable buuka
diff --git a/default.nix b/default.nix
index 4a4060c..f3e216c 100644
--- a/default.nix
+++ b/default.nix
@@ -1,5 +1,5 @@
 { mkDerivation, aeson, base, bytestring, containers, exceptions
-, filepath, hashids, hedgehog, hedgehog-corpus, lens, mtl
+, filepath, hashable, hashids, hedgehog, hedgehog-corpus, lens, mtl
 , optparse-applicative, stdenv, tasty, tasty-hedgehog, text
 , transformers, unliftio, vector, yaml
 }:
@@ -10,8 +10,8 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    aeson base bytestring containers exceptions filepath hashids lens
-    mtl text transformers unliftio vector yaml
+    aeson base bytestring containers exceptions filepath hashable
+    hashids lens mtl text transformers unliftio vector yaml
   ];
   executableHaskellDepends = [ base optparse-applicative unliftio ];
   testHaskellDepends = [
diff --git a/src/Data/Buuka.hs b/src/Data/Buuka.hs
index 50b96c3..62d1f62 100644
--- a/src/Data/Buuka.hs
+++ b/src/Data/Buuka.hs
@@ -9,35 +9,44 @@ module Data.Buuka
 
   , insert
   , elements
+  , fingerprint
   )
   where
 
 import Database.Migrations
 
 import Data.Aeson
+import Data.Bits
+       (finiteBitSize, shiftR, (.&.))
+import Data.Hashable
+       (Hashable, hash)
 import GHC.Generics
        (Generic)
 
 import Control.Monad.Reader
 import Control.Monad.State
 
+import Data.ByteString
+       (ByteString)
+import qualified Data.ByteString as B
+
 newtype URL = URL String
   deriving stock (Show, Eq, Generic, Ord)
-  deriving newtype (ToJSON, FromJSON, FromJSONKey, ToJSONKey)
+  deriving newtype (ToJSON, FromJSON, FromJSONKey, ToJSONKey, Hashable)
 
 data BuukaEntry
   = BuukaEntry { url :: URL
                , title :: Maybe String
                }
   deriving stock (Show, Eq, Generic)
-  deriving anyclass (ToJSON, FromJSON)
+  deriving anyclass (ToJSON, FromJSON, Hashable)
 
 instance SafeJSON BuukaEntry where
   type Version BuukaEntry = 0
 
 newtype Buuka = Buuka [BuukaEntry]
   deriving stock (Show, Eq)
-  deriving newtype (Semigroup, Monoid, FromJSON, ToJSON)
+  deriving newtype (Semigroup, Monoid, FromJSON, ToJSON, Hashable)
 
 insert :: BuukaEntry -> Buuka -> Buuka
 insert e (Buuka b) = Buuka (e : b)
@@ -45,6 +54,14 @@ insert e (Buuka b) = Buuka (e : b)
 elements :: Buuka -> [BuukaEntry]
 elements (Buuka b) = b
 
+-- | Create a (non-cryptographic) hash out of the 'Buuka'
+fingerprint :: Buuka -> ByteString
+fingerprint = toBS . hash
+  where
+    toBS x =
+      let bs = finiteBitSize x
+      in B.pack [fromIntegral ((x `shiftR` s) .&. 255) | s <- [0..bs - 1]]
+
 instance SafeJSON Buuka where
   type Version Buuka = 0
 
diff --git a/src/Operations/List.hs b/src/Operations/List.hs
index 640c197..a51ce50 100644
--- a/src/Operations/List.hs
+++ b/src/Operations/List.hs
@@ -12,7 +12,7 @@ import Data.Semigroup
        (Max(..))
 
 import Data.Buuka
-       (BuukaEntry(..), URL(..))
+       (Buuka, BuukaEntry(..), URL(..))
 import qualified Data.Buuka as B
 
 import Web.Hashids
@@ -23,15 +23,18 @@ import Data.Text.Strict.Lens
 
 list :: BuukaM ()
 list =
-  buukaQ (asks (format . B.elements)) >>= traverse_ (liftIO . putStrLn)
+  buukaQ (asks go) >>= traverse_ (liftIO . putStrLn)
   where
-    ctx = hashidsSimple "buuka"
-    format :: [BuukaEntry] -> [String]
-    format xs =
-      let formatted = zipWith formatEntry [1..] xs
+    go :: Buuka -> [String]
+    go b =
+      let ctx = hashidsSimple (B.fingerprint b)
+      in format ctx (B.elements b)
+    format :: HashidsContext -> [BuukaEntry] -> [String]
+    format ctx xs =
+      let formatted = zipWith (formatEntry ctx) [1..] xs
           indexWidth = getMax . foldMap (Max . length . fst) $ formatted
       in fmap (\(idx,x) -> idx <> replicate (indexWidth - length idx) ' ' <> ". " <> x) formatted
-    formatEntry :: Int -> BuukaEntry -> (String, String)
-    formatEntry n = \case
+    formatEntry :: HashidsContext -> Int -> BuukaEntry -> (String, String)
+    formatEntry ctx n = \case
       BuukaEntry{title=Just t} -> (encode ctx n ^. utf8 . unpacked, t)
       BuukaEntry{url=URL u} -> (encode ctx n ^. utf8 . unpacked, u)