diff --git a/app/Main.hs b/app/Main.hs index cf3c54a..662dec2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -27,6 +27,7 @@ commands = subparser ( 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 = diff --git a/buuka.cabal b/buuka.cabal index 8b64432..c4d48b2 100644 --- a/buuka.cabal +++ b/buuka.cabal @@ -40,6 +40,7 @@ library , Operations.Insert , Operations.List , Operations.Query + , Operations.Import.Firefox , Operations , Data.Environment , Data.Buuka @@ -61,6 +62,9 @@ library , lens , hashable , regex-tdfa + , sqlite-simple + , conduit + , conduit-extra hs-source-dirs: src executable buuka diff --git a/default.nix b/default.nix index 795a5dd..ece3a3d 100644 --- a/default.nix +++ b/default.nix @@ -1,8 +1,9 @@ -{ mkDerivation, aeson, base, bytestring, containers -, deriving-compat, exceptions, filepath, hashable, hashids -, hedgehog, hedgehog-corpus, lens, mtl, optparse-applicative -, regex-tdfa, stdenv, tasty, tasty-hedgehog, tasty-hunit, text -, transformers, unliftio, vector, yaml +{ mkDerivation, aeson, base, bytestring, conduit, conduit-extra +, containers, deriving-compat, exceptions, filepath, hashable +, hashids, hedgehog, hedgehog-corpus, lens, mtl +, optparse-applicative, regex-tdfa, sqlite-simple, stdenv, tasty +, tasty-hedgehog, tasty-hunit, text, transformers, unliftio, vector +, yaml }: mkDerivation { pname = "buuka"; @@ -11,8 +12,9 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson base bytestring containers exceptions filepath hashable - hashids lens mtl regex-tdfa text transformers unliftio vector yaml + aeson base bytestring conduit conduit-extra containers exceptions + filepath hashable hashids lens mtl regex-tdfa sqlite-simple text + transformers unliftio vector yaml ]; executableHaskellDepends = [ base optparse-applicative unliftio ]; testHaskellDepends = [ diff --git a/src/Data/Buuka.hs b/src/Data/Buuka.hs index 62d1f62..fc1d9c2 100644 --- a/src/Data/Buuka.hs +++ b/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 + import Control.Monad.Reader import Control.Monad.State @@ -30,17 +39,22 @@ 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 - , title :: Maybe String + = BuukaEntry { _url :: URL + , _title :: Maybe Text } deriving stock (Show, Eq, Generic) deriving anyclass (ToJSON, FromJSON, Hashable) +makeLenses ''BuukaEntry + instance SafeJSON BuukaEntry where type Version BuukaEntry = 0 @@ -48,6 +62,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) diff --git a/src/Data/Query.hs b/src/Data/Query.hs index 138ed12..4425caa 100644 --- a/src/Data/Query.hs +++ b/src/Data/Query.hs @@ -18,10 +18,9 @@ module Data.Query where import Data.Buuka - (BuukaEntry(..), URL(..)) + (BuukaEntry, title, url, _URL) -import Data.List - (isPrefixOf, isSuffixOf) +import Control.Lens import Text.Regex.TDFA ((=~)) @@ -29,27 +28,31 @@ 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 String - Title :: Field String + Url :: Field Text + Title :: Field Text data QueryF f where - StartsWith :: Field String -> String -> QueryF f - EndsWith :: Field String -> String -> QueryF f - Regex :: Field String -> String -> QueryF f + StartsWith :: Field Text -> Text -> QueryF f + EndsWith :: Field Text -> Text -> QueryF f + Regex :: Field Text -> Text -> QueryF f And :: f -> f -> QueryF f deriving instance Functor QueryF type Query = Fix QueryF -startsWith :: Field String -> String -> Query +startsWith :: Field Text -> Text -> Query startsWith field x = Fix (StartsWith field x) -endsWith :: Field String -> String -> Query +endsWith :: Field Text -> Text -> Query endsWith field x = Fix (EndsWith field x) -regex :: Field String -> String -> Query +regex :: Field Text -> Text -> Query regex field x = Fix (Regex field x) (.&&.) :: Query -> Query -> Query @@ -57,12 +60,12 @@ a .&&. b = Fix (And a b) evaluate :: QueryF (BuukaEntry -> Bool) -> (BuukaEntry -> Bool) evaluate = \case - StartsWith Url x -> \BuukaEntry{url=URL u} -> x `isPrefixOf` u - EndsWith Url x -> \BuukaEntry{url=URL u} -> x `isSuffixOf` u - StartsWith Title x -> \BuukaEntry{title=t} -> maybe False (x `isPrefixOf`) t - EndsWith Title x -> \BuukaEntry{title=t} -> maybe False (x `isSuffixOf`) t - Regex Url x -> \BuukaEntry{url=URL u} -> u =~ x - Regex Title x -> \BuukaEntry{title=t} -> maybe False (=~ x) t + StartsWith Url x -> \e -> x `T.isPrefixOf` (e ^. url . _URL) + EndsWith Url x -> \e -> x `T.isSuffixOf` (e ^. url . _URL) + StartsWith Title x -> \e -> maybe False (x `T.isPrefixOf`) $ e ^. title + EndsWith Title x -> \e -> maybe False (x `T.isSuffixOf`) $ e ^. title + 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 predicate :: Query -> BuukaEntry -> Bool diff --git a/src/Operations.hs b/src/Operations.hs index c0ed6d6..57f331a 100644 --- a/src/Operations.hs +++ b/src/Operations.hs @@ -2,6 +2,7 @@ module Operations ( module Operations.Insert , module Operations.List , module Operations.Query + , module Operations.Import.Firefox ) where @@ -11,3 +12,5 @@ import Operations.List (list) import Operations.Query (query) +import Operations.Import.Firefox + (importFirefox) diff --git a/src/Operations/Format.hs b/src/Operations/Format.hs index b155c77..f4524c4 100644 --- a/src/Operations/Format.hs +++ b/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 - in fmap (\(idx,x) -> idx <> replicate (indexWidth - length idx) ' ' <> ". " <> x) formatted + 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 -> (String, String) + formatEntry :: Int -> BuukaEntry -> (Text, Text) formatEntry n = \case - BuukaEntry{title=Just t} -> (encode ctx n ^. utf8 . unpacked, t) - BuukaEntry{url=URL u} -> (encode ctx n ^. utf8 . unpacked, u) + BuukaEntry{_title=Just t} -> (encode ctx n ^. utf8, t) + BuukaEntry{_url=URL u} -> (encode ctx n ^. utf8, u) diff --git a/src/Operations/Import/Firefox.hs b/src/Operations/Import/Firefox.hs new file mode 100644 index 0000000..0c86d7a --- /dev/null +++ b/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 :: 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 = Just _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 diff --git a/src/Operations/Insert.hs b/src/Operations/Insert.hs index 4f840d2..84561d3 100644 --- a/src/Operations/Insert.hs +++ b/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 } diff --git a/src/Operations/List.hs b/src/Operations/List.hs index d786655..7db1f0b 100644 --- a/src/Operations/List.hs +++ b/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) diff --git a/src/Operations/Query.hs b/src/Operations/Query.hs index 0ed3a5e..d871181 100644 --- a/src/Operations/Query.hs +++ b/src/Operations/Query.hs @@ -14,10 +14,14 @@ import qualified Data.Buuka as B import Operations.Format -query :: Field String -> String -> BuukaM () +import Data.Text + (Text) +import qualified Data.Text.IO as T + +query :: Field Text -> Text -> BuukaM () query field q = - buukaQ (asks go) >>= traverse_ (liftIO . putStrLn) + buukaQ (asks go) >>= traverse_ (liftIO . T.putStrLn) where - go :: Buuka -> [String] + go :: Buuka -> [Text] go b = formatEntries b (filter (predicate (regex field q)) . B.elements $ b) diff --git a/test/Test/Data/Buuka.hs b/test/Test/Data/Buuka.hs index 5e65b10..8149767 100644 --- a/test/Test/Data/Buuka.hs +++ 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