Bump versions and multiple queries

Reviewed-on: #1

app/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Main where
 
 import Options.Applicative
@@ -7,17 +8,40 @@ import Control.Monad.Buuka
 
 import Data.Environment
 
+import UnliftIO.Directory
+       (XdgDirectory(XdgData), getXdgDirectory)
+
+import Data.Foldable
+       (asum)
+
+import System.Environment
+       (lookupEnv)
+
 import qualified Operations
 
+import Data.Query
+       (Field(..))
+import qualified Options.Applicative.NonEmpty as NE
+
 commands :: Parser (BuukaM ())
 commands = subparser
-  (  command "insert" (info (insertOpts Operations.insert) (progDesc "Insert a new bookmark")))
+  (  command "insert" (info (insertOpts Operations.insert <**> helper) (progDesc "Insert a new bookmark"))
+  <> command "list" (info (pure Operations.list <**> helper) (progDesc "List all the bookmarks"))
+  <> command "query" (info (queryOpts Operations.query <**> helper) (progDesc "Query the bookmarks"))
+  <> command "import" (info (pure Operations.importFirefox <**> helper) (progDesc "Import"))
+  )
   where
     insertOpts f =
         f <$> strOption (long "url" <> short 'u' <> metavar "URL")
           <*> optional (strOption (long "title"))
+    queryOpts f =
+      f <$> NE.some1 (asum [tagged Title "title", tagged Url "url"])
+    tagged t x = (t, ) <$> strOption (long x <> metavar "REGEX")
 
 main :: IO ()
 main = do
-  let env = Environment "."
-  execParser (info (commands <**> helper) fullDesc) >>= runBuukaM env
+  env <- Environment <$> (lookupEnv "BUUKA_HOME" >>= maybe defaultHome pure)
+  execParser (info (commands <**> helper) (fullDesc <> progDesc description)) >>= runBuukaM env
+    where
+      defaultHome = getXdgDirectory XdgData "buuka"
+      description = "Bookmarks manager. Stores the bookmarks in a yaml file under your xdg directory or in a folder specified by the BUUKA_HOME environment variable"

buuka.cabal

@@ -16,7 +16,7 @@ category:            Web
 extra-source-files:  CHANGELOG.md
 
 common common-stanza
-  build-depends:       base ^>=4.13.0.0
+  build-depends:       base >=4.13.0.0 && <4.15
   default-extensions:  OverloadedStrings
                      , ScopedTypeVariables
                      , DerivingVia
@@ -36,22 +36,35 @@ library
   exposed-modules:     MyLib
                      , Database.Migrations
                      , Control.Monad.Buuka
+                     , Operations.Format
                      , Operations.Insert
+                     , Operations.List
+                     , Operations.Query
+                     , Operations.Import.Firefox
                      , Operations
                      , Data.Environment
                      , Data.Buuka
+                     , Data.Query
+                     , Data.Functor.Foldable
   -- other-modules:
   build-depends:       aeson
                      , yaml
                      , mtl
                      , transformers
                      , unliftio
-                     , conduit
-                     , conduit-extra
                      , containers
                      , exceptions
                      , bytestring
                      , filepath
+                     , vector
+                     , hashids
+                     , text
+                     , lens
+                     , hashable
+                     , regex-tdfa
+                     , sqlite-simple
+                     , conduit
+                     , conduit-extra
   hs-source-dirs:      src
 
 executable buuka
@@ -61,11 +74,15 @@ executable buuka
   -- other-extensions:
   build-depends:       buuka
                      , optparse-applicative
+                     , unliftio
   hs-source-dirs:      app
 
 test-suite buuka-test
   import:              common-stanza
   other-modules:       Test.Database.Migrations
+                       Test.Data.Buuka
+                       Test.Data.Query
+                       Test.Data.Functor.Foldable
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
   main-is:             MyLibTest.hs
@@ -73,6 +90,8 @@ test-suite buuka-test
                      , hedgehog
                      , hedgehog-corpus
                      , tasty-hedgehog
+                     , tasty-hunit
                      , tasty
                      , text
                      , aeson
+                     , deriving-compat

default.nix

@@ -1,7 +1,9 @@
 { mkDerivation, aeson, base, bytestring, conduit, conduit-extra
-, containers, exceptions, filepath, hedgehog, hedgehog-corpus, mtl
-, optparse-applicative, stdenv, tasty, tasty-hedgehog, text
-, transformers, unliftio, yaml
+, containers, deriving-compat, exceptions, filepath, hashable
+, hashids, hedgehog, hedgehog-corpus, lens, lib, mtl
+, optparse-applicative, regex-tdfa, sqlite-simple, tasty
+, tasty-hedgehog, tasty-hunit, text, transformers, unliftio, vector
+, yaml
 }:
 mkDerivation {
   pname = "buuka";
@@ -11,11 +13,13 @@ mkDerivation {
   isExecutable = true;
   libraryHaskellDepends = [
     aeson base bytestring conduit conduit-extra containers exceptions
-    filepath mtl transformers unliftio yaml
+    filepath hashable hashids lens mtl regex-tdfa sqlite-simple text
+    transformers unliftio vector yaml
   ];
-  executableHaskellDepends = [ base optparse-applicative ];
+  executableHaskellDepends = [ base optparse-applicative unliftio ];
   testHaskellDepends = [
-    aeson base hedgehog hedgehog-corpus tasty tasty-hedgehog text
+    aeson base deriving-compat hedgehog hedgehog-corpus tasty
+    tasty-hedgehog tasty-hunit text
   ];
-  license = stdenv.lib.licenses.bsd3;
+  license = lib.licenses.bsd3;
 }

shell.nix

@@ -1,17 +1,26 @@
 with (import <nixpkgs> {});
 
 let
+  hp = haskellPackages.extend (self: super: {
     buuka = haskellPackages.callPackage ./. {};
+  });
+  easy-hls-src = fetchFromGitHub {
+    owner = "ssbothwell";
+    repo = "easy-hls-nix";
+    inherit (builtins.fromJSON (builtins.readFile ./easy-hls-nix.json)) rev sha256;
+  };
+  easy-hls = callPackage easy-hls-src { ghcVersions = [ hp.ghc.version ]; };
 
 in
 
-mkShell {
-  name = "shell-buuka";
+hp.shellFor {
+  packages = h: [h.buuka];
   buildInputs = [
+    hlint
     ghcid
     stylish-haskell
     cabal2nix
-    haskellPackages.cabal-install
-    (haskellPackages.ghcWithHoogle (_: buuka.buildInputs ++ buuka.propagatedBuildInputs))
+    cabal-install
+    easy-hls
   ];
 }

src/Control/Monad/Buuka.hs

@@ -25,7 +25,7 @@ import Control.Monad.State
 import UnliftIO
        (MonadUnliftIO(..))
 import UnliftIO.Directory
-       (copyFile)
+       (copyFile, createDirectoryIfMissing)
 import UnliftIO.Temporary
        (withSystemTempDirectory)
 
@@ -44,7 +44,9 @@ newtype BuukaM a = BuukaM (ReaderT Environment IO a)
                    )
 
 runBuukaM :: Environment -> BuukaM a -> IO a
-runBuukaM env (BuukaM f) = runReaderT f env
+runBuukaM env (BuukaM f) = do
+  createDirectoryIfMissing True (workdir env)
+  runReaderT f env
 
 data DecodeException
   = YamlParseException ParseException
@@ -56,7 +58,7 @@ buukaQ :: BuukaQ a -> BuukaM a
 buukaQ q = do
   w <- asks workdir
   decoded <- (decode <$> liftIO (B.readFile (w </> "buuka.yaml"))) `catch` handleNotFound
-  either (throwM) (pure . runReader (runBuukaQ q)) decoded
+  either throwM (pure . runReader (runBuukaQ q)) decoded
   where
     handleNotFound IOError{ioe_type = NoSuchThing} = pure (Right mempty)
     handleNotFound e = throwM e

src/Data/Buuka.hs

@@ -1,47 +1,92 @@
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeFamilies #-}
 module Data.Buuka
   ( BuukaQ(..)
   , BuukaU(..)
   , BuukaEntry(..)
+  , url
+  , title
   , URL(..)
+  , _URL
+  , Buuka
+  , _Buuka
 
   , insert
+  , elements
+  , fingerprint
   )
   where
 
-import Data.Map
-       (Map)
-import qualified Data.Map.Strict as M
+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
 
-newtype URL = URL String
+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)
+  deriving newtype (ToJSON, FromJSON, FromJSONKey, ToJSONKey, Hashable)
+
+_URL :: Iso' URL Text
+_URL = iso (\(URL t) -> t) URL
 
 data BuukaEntry
-  = BuukaEntry { url :: URL
-               , title :: Maybe String
+  = BuukaEntry { _url :: URL
+               , _title :: Maybe Text
                }
   deriving stock (Show, Eq, Generic)
-  deriving anyclass (ToJSON, FromJSON)
+  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 ( Map URL BuukaEntry )
-  deriving newtype (Semigroup, Monoid, FromJSON, ToJSON)
+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 (M.insert (url e) e b)
+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/Data/Functor/Foldable.hs

@@ -0,0 +1,44 @@
+{-|
+Module      : Data.Functor.Foldable
+Description : Simplified recursion schemes
+Copyright   : (c) Mats Rauhala, 2020
+License     : BSD-3-Clause
+Maintainer  : mats.rauhala@iki.fi
+Stability   : experimental
+Portability : POSIX
+
+Simplified recursion schemes, providing only the minimal schemes
+-}
+module Data.Functor.Foldable
+  ( Fix(..)
+  , cata
+  , ana
+  , hylo
+  )
+  where
+
+import Data.Functor.Classes
+
+newtype Fix f = Fix { getFix :: f (Fix f) }
+
+instance Show1 f => Show (Fix f) where
+  showsPrec d (Fix f) = showString "Fix " . showsPrec1 d f
+
+instance Eq1 f => Eq (Fix f) where
+  (Fix a) == (Fix b) = liftEq (==) a b
+
+-- | Catamorphism or the fold
+--
+-- Fold a recursive structure into a value
+cata :: Functor f => (f a -> a) -> Fix f -> a
+cata f = a where a = f . fmap a . getFix
+
+-- | Anamorphism or the unfold
+--
+-- Unfold a seed into a recursive structure
+ana :: Functor f => (a -> f a) -> a -> Fix f
+ana f = a where a = Fix . fmap a . f
+
+-- | Combined fold and unfold
+hylo :: (Functor f) => (f a -> a) -> (b -> f b) -> b -> a
+hylo f u = a where a = f . fmap a . u

src/Data/Query.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Data.Query
+  (
+    -- * AST
+    Field(..)
+
+    -- * Combinators
+  , startsWith
+  , endsWith
+  , regex
+  , (.&&.)
+
+    -- * Evaluating queries
+  , evaluate
+  , predicate
+  )
+  where
+
+import Data.Buuka
+       (BuukaEntry, title, url, _URL)
+
+import Control.Lens
+
+import Text.Regex.TDFA
+       ((=~))
+
+import Data.Functor.Foldable
+       (Fix(..), cata)
+
+import Data.Text
+       (Text)
+import qualified Data.Text as T
+
+data Field a where
+  Url :: Field Text
+  Title :: Field Text
+
+data QueryF f where
+  StartsWith :: Field Text -> Text -> QueryF f
+  EndsWith :: Field Text -> Text -> QueryF f
+  Regex :: Field Text -> Text -> QueryF f
+  And :: f -> f -> QueryF f
+  Pass :: QueryF f
+
+deriving instance Functor QueryF
+
+type Query = Fix QueryF
+
+-- Query is a semigroup over the &&
+instance Semigroup Query where
+  (<>) = (.&&.)
+
+-- Identity is the constant true
+instance Monoid Query where
+  mempty = Fix Pass
+
+startsWith :: Field Text -> Text -> Query
+startsWith field x = Fix (StartsWith field x)
+
+endsWith :: Field Text -> Text -> Query
+endsWith field x = Fix (EndsWith field x)
+
+regex :: Field Text -> Text -> Query
+regex field x = Fix (Regex field x)
+
+(.&&.) :: Query -> Query -> Query
+a .&&. b = Fix (And a b)
+
+evaluate :: QueryF (BuukaEntry -> Bool) -> (BuukaEntry -> Bool)
+evaluate = \case
+  StartsWith Url x -> has (url . _URL . prefixed x)
+  EndsWith Url x -> has (url . _URL . suffixed x)
+  StartsWith Title x -> has (title . _Just . prefixed x)
+  EndsWith Title x -> has (title . _Just . suffixed x)
+  Regex Url x -> \e -> (e ^. url . _URL) =~ x
+  Regex Title x -> \e -> maybe False (=~ x) $ e ^. title
+  And a b -> \e -> a e && b e
+  Pass -> const True
+  where
+    prefixed ps = prism' (ps <>) (T.stripPrefix ps)
+    suffixed qs = prism' (<> qs) (T.stripSuffix qs)
+
+predicate :: Query -> BuukaEntry -> Bool
+predicate = cata evaluate
+

src/Operations.hs

@@ -1,6 +1,16 @@
 module Operations
-  ( module Operations.Insert )
+  ( module Operations.Insert
+  , module Operations.List
+  , module Operations.Query
+  , module Operations.Import.Firefox
+  )
   where
 
 import Operations.Insert
        (insert)
+import Operations.List
+       (list)
+import Operations.Query
+       (query)
+import Operations.Import.Firefox
+       (importFirefox)

src/Operations/Format.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE LambdaCase #-}
+{-|
+Module      : Operations.Format
+Description : Format the list of bookmarks
+Copyright   : (c) Mats Rauhala, 2020
+License     : BSD-3-Clause
+Maintainer  : mats.rauhala@iki.fi
+Stability   : experimental
+Portability : POSIX
+
+Format the list of bookmarks. It uses the "hashids" module to create a unique
+hash for each entry. Some extra (user) security is given by using the hash of
+the full entries as the initial context for hashids. If the state has been
+modified between operations, the ids change.
+-}
+module Operations.Format where
+
+import Data.Buuka
+       (Buuka, BuukaEntry(..), URL(..))
+import qualified Data.Buuka as B
+
+import Data.Semigroup
+       (Max(..))
+
+import Web.Hashids
+
+import Control.Lens
+import Data.Text.Strict.Lens
+       (utf8)
+
+import Data.Text
+       (Text)
+import qualified Data.Text as T
+
+-- | Format the entries
+formatEntries
+  :: Buuka -- ^ The full set of entries, for the context
+  -> [BuukaEntry] -- ^ The list of entries to be formatted
+  -> [Text]
+formatEntries buuka xs =
+  let formatted = zipWith formatEntry [1..] xs
+      indexWidth = getMax . foldMap (Max . T.length . fst) $ formatted
+  in fmap (\(idx,x) -> idx <> T.replicate (indexWidth - T.length idx) " " <> ". " <> x) formatted
+  where
+    ctx = mkContext buuka
+    mkContext :: Buuka -> HashidsContext
+    mkContext = hashidsSimple . B.fingerprint
+    formatEntry :: Int -> BuukaEntry -> (Text, Text)
+    formatEntry n = \case
+      BuukaEntry{_title=Just t} -> (encode ctx n ^. utf8, t)
+      BuukaEntry{_url=URL u} -> (encode ctx n ^. utf8, u)

src/Operations/Import/Firefox.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-|
+Module      : Operations.Import.Firefox
+Description : Imports from firefox
+Copyright   : (c) Mats Rauhala, 2020
+License     : BSD-3-Clause
+Maintainer  : mats.rauhala@iki.fi
+Stability   : experimental
+Portability : POSIX
+
+Imports from firefox. Firefox needs to be closed when doing the import
+-}
+module Operations.Import.Firefox
+  ( importFirefox )
+  where
+
+import Data.Monoid
+       (Endo(..))
+
+import qualified Data.Foldable as F
+import qualified Data.Set as S
+
+import Control.Monad.State
+       (modify)
+
+import Data.Buuka
+       (Buuka)
+import qualified Data.Buuka as B
+
+import Conduit
+import qualified Data.Conduit.Combinators as C
+
+import Data.Text
+       (Text)
+
+import System.FilePath
+       (takeFileName, (</>))
+
+import Control.Exception
+       (Exception)
+
+import System.Environment
+       (lookupEnv)
+
+import GHC.Stack
+
+import Control.Lens
+       ( Lens'
+       , foldMapOf
+       , folded
+       , has
+       , ix
+       , lens
+       , makeLenses
+       , to
+       , (%~)
+       , (&)
+       , (<>~)
+       , (^.)
+       )
+
+import qualified Database.SQLite.Simple as SQL
+
+import Data.Traversable
+       (for)
+
+import Control.Monad.Buuka
+
+-- select p.title, p.url from moz_bookmarks b join moz_places p on b.fk = p.id
+--
+-- select keyword from moz_keywords where place_id = ?
+
+newtype ImportException
+  = HomeNotFound CallStack
+  deriving stock (Show)
+  deriving anyclass (Exception)
+
+data Firefox
+  = Firefox { _url :: Text
+            , _title :: Maybe Text
+            , _keywords :: [Text]
+            }
+  deriving stock (Show, Eq)
+
+url :: Lens' Firefox Text
+url = lens _url (\f u -> f{_url = u})
+
+stores
+  :: MonadResource m
+  => MonadThrow m
+  => MonadIO m
+  => HasCallStack
+  => ConduitT i FilePath m ()
+stores = liftIO (lookupEnv "HOME") >>= maybe (throwM (HomeNotFound callStack)) listStores
+  where
+    listStores home =
+      sourceDirectoryDeep False (home </> ".mozilla/firefox")
+        .| C.filter (\p -> takeFileName p == "places.sqlite")
+
+bookmarks :: MonadIO m => FilePath -> m [Firefox]
+bookmarks path = liftIO $ SQL.withConnection path $ \conn -> do
+  elems <- SQL.query_ conn "select p.id, p.title, p.url from moz_bookmarks b join moz_places p on b.fk = p.id"
+  for elems $ \(_id, _title, _url) -> do
+    _keywords <- fmap SQL.fromOnly <$> SQL.query conn "select keyword from moz_keywords where place_id = ?" (SQL.Only @Int _id)
+    pure Firefox{..}
+
+data Update
+  = Update { _buuka :: !Buuka
+           , _seen :: !(S.Set Text)
+           }
+  deriving stock (Show)
+
+makeLenses ''Update
+
+importFirefox :: BuukaM ()
+importFirefox = do
+  -- Collect all the imported bookmarks
+  fs <- (`appEndo` []) <$> runResourceT (runConduit $ stores .| C.mapM bookmarks .| C.foldMap (\f -> Endo (++ f)))
+  -- Insert to the buuka store iff, the urls don't already exist in the store
+  -- The fold keeps track of a set of already seen entries. Every iteration
+  -- adds the current url to the known set of urls. Only if the url doesn't
+  -- exist in the set, will it be inserted to the store
+  buukaU $ modify $ \oldState -> F.foldl' update (initialState oldState) fs ^. buuka
+  where
+    toEntry Firefox{..} = B.BuukaEntry{ B._url = B.URL _url, B._title = _title }
+    update acc f = acc
+      & seen <>~ (f ^. url . to S.singleton)
+      & if has (seen . ix (f ^. url)) acc then id else buuka %~ B.insert (toEntry f)
+    initialState oldState = Update oldState (initialUrls oldState)
+    initialUrls = foldMapOf (B._Buuka . folded . B.url . B._URL) S.singleton

src/Operations/Insert.hs

@@ -7,7 +7,10 @@ import Control.Monad.State
 
 import qualified Data.Buuka as B
 
-insert :: String -> Maybe String -> BuukaM ()
+import Data.Text
+       (Text)
+
+insert :: Text -> Maybe Text -> BuukaM ()
 insert url title = buukaU (modify (B.insert entry))
   where
-    entry = B.BuukaEntry{ B.url = B.URL url, B.title = title }
+    entry = B.BuukaEntry{ B._url = B.URL url, B._title = title }

src/Operations/List.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE LambdaCase #-}
+module Operations.List where
+
+import Control.Monad.Buuka
+import Control.Monad.Reader
+       (asks, liftIO)
+
+import Data.Foldable
+       (traverse_)
+
+import Data.Buuka
+       (Buuka)
+import qualified Data.Buuka as B
+
+import Operations.Format
+
+import Data.Text
+       (Text)
+import qualified Data.Text.IO as T
+
+
+list :: BuukaM ()
+list =
+  buukaQ (asks go) >>= traverse_ (liftIO . T.putStrLn)
+  where
+    go :: Buuka -> [Text]
+    go b = formatEntries b (B.elements b)

src/Operations/Query.hs

@@ -0,0 +1,29 @@
+module Operations.Query where
+
+import Data.Query
+
+import Control.Monad.Buuka
+import Control.Monad.Reader
+
+import Data.Foldable
+       (traverse_)
+
+import Data.Buuka
+       (Buuka)
+import qualified Data.Buuka as B
+
+import Operations.Format
+
+import Data.Text
+       (Text)
+import qualified Data.Text.IO as T
+import Data.List.NonEmpty (NonEmpty)
+
+query :: NonEmpty (Field Text, Text) -> BuukaM ()
+query qs =
+  buukaQ (asks go) >>= traverse_ (liftIO . T.putStrLn)
+  where
+    q = foldMap (uncurry regex) qs
+    go :: Buuka -> [Text]
+    go b = formatEntries b (filter (predicate q) . B.elements $ b)
+

test/MyLibTest.hs

@@ -2,11 +2,17 @@ module Main (main) where
 
 import Test.Tasty
 
+import qualified Test.Data.Buuka as Data.Buuka
+import qualified Test.Data.Query as Data.Query
+import qualified Test.Data.Functor.Foldable as Data.Functor.Foldable
 import qualified Test.Database.Migrations as Database.Migrations
 
 tests :: TestTree
 tests = testGroup "buuka"
   [ Database.Migrations.tests
+  , Data.Buuka.tests
+  , Data.Functor.Foldable.tests
+  , Data.Query.tests
   ]
 
 main :: IO ()

test/Test/Data/Buuka.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Test.Data.Buuka where
+
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import Test.Tasty
+import Test.Tasty.Hedgehog
+
+import qualified Data.Aeson as A
+
+import qualified Data.Foldable as F
+
+import qualified Data.Text as T
+
+import Data.Buuka
+
+genUrl :: Gen URL
+genUrl = URL . T.concat <$> sequence go
+  where
+    go = [ Gen.element protocols, Gen.element domains, Gen.element tlds, pure "/", genPath ]
+    protocols = ["http://", "https://"]
+    domains = ["example", "foo", "bar"]
+    tlds = ["com", "fi", "org", "net", "info"]
+    genPath = T.intercalate "/" <$> Gen.list (Range.linear 0 10) (Gen.element paths)
+    paths = ["foo", "bar", "asd", "xyzzy"]
+
+genBuukaEntry :: Gen BuukaEntry
+genBuukaEntry = BuukaEntry <$> genUrl <*> genTitle
+  where
+    genTitle = Gen.maybe (Gen.text (Range.linear 0 10) Gen.unicode)
+
+genBuuka :: Gen Buuka
+genBuuka = F.foldl' (flip insert) mempty <$> Gen.list (Range.linear 0 10) genBuukaEntry
+
+prop_buukaentry_encode_decode :: Property
+prop_buukaentry_encode_decode = property $ do
+  x <- forAll genBuukaEntry
+  tripping x A.encode A.eitherDecode
+
+prop_buuka_encode_decode :: Property
+prop_buuka_encode_decode = property $ do
+  x <- forAll genBuuka
+  tripping x A.encode A.eitherDecode
+
+tests :: TestTree
+tests = testGroup "Data.Buuka"
+  [ testProperty "Entries can be encoded and decoded" prop_buukaentry_encode_decode
+  , testProperty "Entire set can be encoded and decoded" prop_buuka_encode_decode
+  ]

test/Test/Data/Functor/Foldable.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Test.Data.Functor.Foldable where
+
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import Test.Tasty
+import Test.Tasty.Hedgehog
+
+import Data.Eq.Deriving
+       (deriveEq1)
+import Text.Show.Deriving
+       (deriveShow1)
+
+import Data.Functor.Foldable
+
+data AST f
+  = Addition f f
+  | Value Int
+  deriving stock (Functor, Eq, Show)
+
+deriveShow1 ''AST
+deriveEq1 ''AST
+
+evaluate :: AST Int -> Int
+evaluate = \case
+  Addition a b -> a + b
+  Value x -> x
+
+render :: AST String -> String
+render = \case
+  Addition a b -> a <> " + " <> b
+  Value x -> show x
+
+parse :: [String] -> AST [String]
+parse = \case
+  a : "+" : b : xs -> Addition (a : xs) [b]
+  [a] -> Value (read a)
+  _ -> Value 0
+
+genAST :: Gen (Fix AST)
+genAST = Gen.recursive Gen.choice
+  [ Fix . Value <$> Gen.integral (Range.linear 0 100) ]
+  [ Gen.subterm2 genAST genAST (\a b -> Fix (Addition a b))
+  ]
+
+prop_parse_render_tripping :: Property
+prop_parse_render_tripping = property $ do
+  x <- forAll genAST
+  let rendered = cata render x
+      parsed = ana parse . words $ rendered
+  annotateShow rendered
+  annotateShow parsed
+  annotateShow $ cata evaluate x
+  cata evaluate parsed === cata evaluate x
+
+prop_parse_render_hylo :: Property
+prop_parse_render_hylo = property $ do
+  x <- forAll genAST
+  let rendered = cata render x
+  hylo evaluate parse (words rendered) === cata evaluate x
+
+tests :: TestTree
+tests = testGroup "Data.Functor.Foldable"
+  [ testProperty "cata and ana do reverse" $ prop_parse_render_tripping
+  , testProperty "hylo do reverse" $ prop_parse_render_hylo
+  ]

test/Test/Data/Query.hs

@@ -0,0 +1,39 @@
+module Test.Data.Query where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Data.Buuka
+       (BuukaEntry(..), URL(..))
+import Data.Functor.Foldable
+       (cata)
+import Data.Query
+
+test_startswith :: Assertion
+test_startswith = do
+  let entry = BuukaEntry (URL "http://example.com") (Just "foo")
+  cata evaluate (startsWith Url "http://") entry @?= True
+  cata evaluate (startsWith Url "https://") entry @?= False
+  cata evaluate (startsWith Title "foo") entry @?= True
+  cata evaluate (startsWith Title "bar") entry @?= False
+
+test_endswith :: Assertion
+test_endswith = do
+  let entry = BuukaEntry (URL "http://example.com") (Just "foo")
+  cata evaluate (endsWith Url "com") entry @?= True
+  cata evaluate (endsWith Url "fi") entry @?= False
+  cata evaluate (endsWith Title "foo") entry @?= True
+  cata evaluate (endsWith Title "bar") entry @?= False
+
+test_and :: Assertion
+test_and = do
+  let entry = BuukaEntry (URL "http://example.com") (Just "foo")
+  cata evaluate (startsWith Url "http://" .&&. endsWith Url ".com") entry @?= True
+  cata evaluate (startsWith Url "http://" .&&. endsWith Url ".fi") entry @?= False
+
+tests :: TestTree
+tests = testGroup "Data.Query"
+  [ testCase "Queries startsWith" test_startswith
+  , testCase "Queries endsWith" test_endswith
+  , testCase "Queries and" test_and
+  ]