Merge pull request 'import from firefox' (#1) from import into master

Reviewed-on: #1

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 =

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

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, mtl
-, regex-tdfa, stdenv, tasty, tasty-hedgehog, tasty-hunit, text
+, optparse-applicative, regex-tdfa, sqlite-simple, stdenv, tasty
-, transformers, unliftio, vector, yaml
+, 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
+    aeson base bytestring conduit conduit-extra containers exceptions
-    hashids lens mtl regex-tdfa 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 = [

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
+  = BuukaEntry { _url :: URL
-               , title :: Maybe String
+               , _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)
 

src/Data/Query.hs

@@ -18,10 +18,9 @@ module Data.Query
   where
 
 import Data.Buuka
-       (BuukaEntry(..), URL(..))
+       (BuukaEntry, title, url, _URL)
 
-import Data.List
+import Control.Lens
-       (isPrefixOf, isSuffixOf)
 
 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
+  Url :: Field Text
-  Title :: Field String
+  Title :: Field Text
 
 data QueryF f where
-  StartsWith :: Field String -> String -> QueryF f
+  StartsWith :: Field Text -> Text -> QueryF f
-  EndsWith :: Field String -> String -> QueryF f
+  EndsWith :: Field Text -> Text -> QueryF f
-  Regex :: Field String -> String -> 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
+  StartsWith Url x -> \e -> x `T.isPrefixOf` (e ^. url . _URL)
-  EndsWith Url x -> \BuukaEntry{url=URL u} -> x `isSuffixOf` u
+  EndsWith Url x -> \e -> x `T.isSuffixOf` (e ^. url . _URL)
-  StartsWith Title x -> \BuukaEntry{title=t} -> maybe False (x `isPrefixOf`) t
+  StartsWith Title x -> \e -> maybe False (x `T.isPrefixOf`) $ e ^. title
-  EndsWith Title x -> \BuukaEntry{title=t} -> maybe False (x `isSuffixOf`) t
+  EndsWith Title x -> \e -> maybe False (x `T.isSuffixOf`) $ e ^. title
-  Regex Url x -> \BuukaEntry{url=URL u} -> u =~ x
+  Regex Url x -> \e -> (e ^. url . _URL) =~ x
-  Regex Title x -> \BuukaEntry{title=t} -> maybe False (=~ x) t
+  Regex Title x -> \e -> maybe False (=~ x) $ e ^. title
   And a b -> \e -> a e && b e
 
 predicate :: Query -> BuukaEntry -> Bool

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)

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 :: 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

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

@@ -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)
 

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