Bump versions and multiple queries

Reviewed-on: #1

app/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Main where
 
 import Options.Applicative
@@ -10,19 +11,37 @@ 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) (progDesc "List all the bookmarks"))
+  <> 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
-  env <- Environment <$> getXdgDirectory XdgData "buuka"
+  env <- Environment <$> (lookupEnv "BUUKA_HOME" >>= maybe defaultHome pure)
-  execParser (info (commands <**> helper) fullDesc) >>= runBuukaM env
+  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,9 +36,11 @@ library
   exposed-modules:     MyLib
                      , Database.Migrations
                      , Control.Monad.Buuka
+                     , Operations.Format
                      , Operations.Insert
                      , Operations.List
-                     , Operations.Format
+                     , Operations.Query
+                     , Operations.Import.Firefox
                      , Operations
                      , Data.Environment
                      , Data.Buuka
@@ -59,6 +61,10 @@ library
                      , text
                      , lens
                      , hashable
+                     , regex-tdfa
+                     , sqlite-simple
+                     , conduit
+                     , conduit-extra
   hs-source-dirs:      src
 
 executable buuka

default.nix

@@ -1,8 +1,9 @@
-{ mkDerivation, aeson, base, bytestring, containers
+{ mkDerivation, aeson, base, bytestring, conduit, conduit-extra
-, deriving-compat, exceptions, filepath, hashable, hashids
+, containers, deriving-compat, exceptions, filepath, hashable
-, hedgehog, hedgehog-corpus, lens, mtl, optparse-applicative
+, hashids, hedgehog, hedgehog-corpus, lens, lib, mtl
-, stdenv, tasty, tasty-hedgehog, tasty-hunit, text, transformers
+, optparse-applicative, regex-tdfa, sqlite-simple, tasty
-, unliftio, vector, yaml
+, tasty-hedgehog, tasty-hunit, text, transformers, unliftio, vector
+, yaml
 }:
 mkDerivation {
   pname = "buuka";
@@ -11,13 +12,14 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    aeson base bytestring containers exceptions filepath hashable
+    aeson base bytestring conduit conduit-extra containers exceptions
-    hashids lens mtl text transformers unliftio vector yaml
+    filepath hashable hashids lens mtl regex-tdfa sqlite-simple text
+    transformers unliftio vector yaml
   ];
   executableHaskellDepends = [ base optparse-applicative unliftio ];
   testHaskellDepends = [
     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,18 +1,26 @@
 with (import <nixpkgs> {});
 
 let
-  buuka = haskellPackages.callPackage ./. {};
+  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 {
+hp.shellFor {
-  name = "shell-buuka";
+  packages = h: [h.buuka];
   buildInputs = [
     hlint
     ghcid
     stylish-haskell
     cabal2nix
-    haskellPackages.cabal-install
+    cabal-install
-    (haskellPackages.ghcWithHoogle (_: buuka.buildInputs ++ buuka.propagatedBuildInputs))
+    easy-hls
   ];
 }

src/Data/Buuka.hs

@@ -1,11 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeFamilies #-}
 module Data.Buuka
   ( BuukaQ(..)
   , BuukaU(..)
   , BuukaEntry(..)
+  , url
+  , title
   , URL(..)
+  , _URL
   , Buuka
+  , _Buuka
 
   , insert
   , elements
@@ -13,6 +18,8 @@ module Data.Buuka
   )
   where
 
+import Control.Lens (makeLenses, Iso', iso)
+
 import Database.Migrations
 
 import Data.Aeson
@@ -23,6 +30,8 @@ import Data.Hashable
 import GHC.Generics
        (Generic)
 
+import Data.Text (Text)
+
 import Control.Monad.Reader
 import Control.Monad.State
 
@@ -30,16 +39,30 @@ import Data.ByteString
        (ByteString)
 import qualified Data.ByteString as B
 
-newtype URL = URL String
+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
+  = BuukaEntry { _url :: URL
-               , title :: Maybe String
+               , _title :: Maybe Text
                }
   deriving stock (Show, Eq, Generic)
-  deriving anyclass (ToJSON, FromJSON, Hashable)
+  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
@@ -48,6 +71,9 @@ 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)
 

src/Data/Query.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Data.Query
   (
     -- * AST
@@ -8,48 +10,79 @@ module Data.Query
     -- * Combinators
   , startsWith
   , endsWith
+  , regex
   , (.&&.)
 
     -- * Evaluating queries
   , evaluate
+  , predicate
   )
   where
 
 import Data.Buuka
-       (BuukaEntry(..), URL(..))
+       (BuukaEntry, title, url, _URL)
 
-import Data.List
+import Control.Lens
-       (isPrefixOf, isSuffixOf)
+
+import Text.Regex.TDFA
+       ((=~))
 
 import Data.Functor.Foldable
-       (Fix(..))
+       (Fix(..), cata)
+
+import Data.Text
+       (Text)
+import qualified Data.Text as T
 
 data Field a where
-  Url :: Field String
+  Url :: Field Text
-  Title :: Field String
+  Title :: Field Text
 
-data QueryF f
+data QueryF f where
-  = forall a. StartsWith (Field a) a
+  StartsWith :: Field Text -> Text -> QueryF f
-  | forall a. EndsWith (Field a) a
+  EndsWith :: Field Text -> Text -> QueryF f
-  | And f f
+  Regex :: Field Text -> Text -> QueryF f
+  And :: f -> f -> QueryF f
+  Pass :: QueryF f
 
 deriving instance Functor QueryF
 
 type Query = Fix QueryF
 
-startsWith :: Field a -> a -> Query
+-- 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 a -> a -> Query
+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 -> \BuukaEntry{url=URL u} -> x `isPrefixOf` u
+  StartsWith Url x -> has (url . _URL . prefixed x)
-  EndsWith Url x -> \BuukaEntry{url=URL u} -> x `isSuffixOf` u
+  EndsWith Url x -> has (url . _URL . suffixed x)
-  StartsWith Title x -> \BuukaEntry{title=t} -> maybe False (x `isPrefixOf`) t
+  StartsWith Title x -> has (title . _Just . prefixed x)
-  EndsWith Title x -> \BuukaEntry{title=t} -> maybe False (x `isSuffixOf`) t
+  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,8 @@
 module Operations
   ( module Operations.Insert
   , module Operations.List
+  , module Operations.Query
+  , module Operations.Import.Firefox
   )
   where
 
@@ -8,3 +10,7 @@ import Operations.Insert
        (insert)
 import Operations.List
        (list)
+import Operations.Query
+       (query)
+import Operations.Import.Firefox
+       (importFirefox)

src/Operations/Format.hs

@@ -26,23 +26,26 @@ import Web.Hashids
 
 import Control.Lens
 import Data.Text.Strict.Lens
-       (unpacked, utf8)
+       (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
-  -> [String]
+  -> [Text]
 formatEntries buuka xs =
   let formatted = zipWith formatEntry [1..] xs
-      indexWidth = getMax . foldMap (Max . length . fst) $ formatted
+      indexWidth = getMax . foldMap (Max . T.length . fst) $ formatted
-  in fmap (\(idx,x) -> idx <> replicate (indexWidth - length idx) ' ' <> ". " <> x) 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 -> (String, String)
+    formatEntry :: Int -> BuukaEntry -> (Text, Text)
     formatEntry n = \case
-      BuukaEntry{title=Just t} -> (encode ctx n ^. utf8 . unpacked, t)
+      BuukaEntry{_title=Just t} -> (encode ctx n ^. utf8, t)
-      BuukaEntry{url=URL u} -> (encode ctx n ^. utf8 . unpacked, u)
+      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

@@ -14,10 +14,14 @@ 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 . putStrLn)
+  buukaQ (asks go) >>= traverse_ (liftIO . T.putStrLn)
   where
-    go :: Buuka -> [String]
+    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/Test/Data/Buuka.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Test.Data.Buuka where
 
 import Hedgehog
@@ -8,26 +9,26 @@ import Test.Tasty.Hedgehog
 
 import qualified Data.Aeson as A
 
-import Data.List
-       (intercalate)
 import qualified Data.Foldable as F
 
+import qualified Data.Text as T
+
 import Data.Buuka
 
 genUrl :: Gen URL
-genUrl = URL . concat <$> sequence go
+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 = intercalate "/" <$> Gen.list (Range.linear 0 10) (Gen.element paths)
+    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.string (Range.linear 0 10) Gen.unicode)
+    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