buuka/src/Data/Buuka.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Buuka
  ( BuukaQ(..)
  , BuukaU(..)
  , BuukaEntry(..)
  , url
  , title
  , URL(..)
  , _URL
  , Buuka
  , _Buuka

  , insert
  , elements
  , fingerprint
  )
  where

import Control.Lens (makeLenses, Iso', iso)

import Database.Migrations

import Data.Aeson
import Data.Bits
       (finiteBitSize, shiftR, (.&.))
import Data.Hashable
       (Hashable, hash)
import GHC.Generics
       (Generic)

import Data.Text (Text)

import Control.Monad.Reader
import Control.Monad.State

import Data.ByteString
       (ByteString)
import qualified Data.ByteString as B

newtype URL = URL Text
  deriving stock (Show, Eq, Generic, Ord)
  deriving newtype (ToJSON, FromJSON, FromJSONKey, ToJSONKey, Hashable)

_URL :: Iso' URL Text
_URL = iso (\(URL t) -> t) URL

data BuukaEntry
  = BuukaEntry { _url :: URL
               , _title :: Maybe Text
               }
  deriving stock (Show, Eq, Generic)
  deriving anyclass (Hashable)

opts :: Options
opts = defaultOptions { fieldLabelModifier = dropWhile (== '_'), omitNothingFields = True }

instance ToJSON BuukaEntry where
  toJSON = genericToJSON opts

instance FromJSON BuukaEntry where
  parseJSON = genericParseJSON opts

makeLenses ''BuukaEntry

instance SafeJSON BuukaEntry where
  type Version BuukaEntry = 0

newtype Buuka = Buuka [BuukaEntry]
  deriving stock (Show, Eq)
  deriving newtype (Semigroup, Monoid, FromJSON, ToJSON, Hashable)

_Buuka :: Iso' Buuka [BuukaEntry]
_Buuka = iso (\(Buuka b) -> b) Buuka

insert :: BuukaEntry -> Buuka -> Buuka
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

newtype BuukaQ a = BuukaQ { runBuukaQ :: Reader Buuka a }
  deriving newtype (Functor, Applicative, Monad, MonadReader Buuka)

-- Last write wins
newtype BuukaU a = BuukaU { runBuukaU :: State Buuka a }
  deriving newtype (Functor, Applicative, Monad, MonadState Buuka)