Fingerprint the 'Buuka' and use it as context

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
 

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)