100 lines
2.2 KiB
Haskell
100 lines
2.2 KiB
Haskell
{-# 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)
|