hbro-contrib-1.2.0.0: Hbro/Bookmarks.hs

-- | Simple bookmarks system: bookmarks are a list of tagged URIs.
--
-- This module is designed to be imported as @qualified@.
module Hbro.Bookmarks
    ( Entry(..)
    , add
    , add'
    , addCustom
    , Hbro.Bookmarks.select
    , Hbro.Bookmarks.select'
    , selectByTag
    , deleteByTag
) where

-- {{{ Imports
import Hbro
-- import Hbro.Error
import Hbro.Gui
import Hbro.Misc

import Control.Monad.Reader hiding(mapM)

import qualified Data.Set as Set
-- import Data.Random.Extras
-- import Data.Random.RVar
-- import Data.Random.Source.DevRandom

import Filesystem hiding(readFile, writeFile)

import Network.URI

import Safe

import Text.Parsec hiding(many)
import Text.Parsec.Text
-- }}}

-- {{{ Type definitions
data Entry = Entry
    { _uri  :: URI
    , _tags :: Set Text
    }

instance Describable Entry where
    describe (Entry uri tags) = unwords $ (tshow uri):(Set.toList tags)
-- }}}

-- Error message
-- invalidBookmarkEntry :: Text -> Text
-- invalidBookmarkEntry = ("Invalid bookmark entry: " ++)

-- | Return bookmarks file
getBookmarksFile :: (BaseIO m) => m FilePath
getBookmarksFile = getAppDataDirectory "hbro" >/> "bookmarks"

-- | Try to parse a Text into a history Entry.
entry :: Parser Entry
entry = do
    spaces
    u <- (some $ satisfy isAllowedInURI) <?> "URI"
    uri <- (maybe mzero return $ parseURI u) <?> "URI"
    some space
    tags <- many $ noneOf "\n"
    return $ Entry uri (Set.fromList . words $ pack tags)


-- | Check if the given bookmark 'Entry' is tagged with the given tag.
hasTag :: Text -> Entry -> Bool
hasTag tag = member tag . _tags

-- | Add current webpage to bookmarks with given tags
add :: (BaseIO m, MonadReader r m, HasGUI r, MonadError Text m, ToSet Text tags) => tags -> m ()
add tags = (`add'` tags) =<< getBookmarksFile

-- | Like 'add', but you can specify the bookmarks file path
add' :: (BaseIO m, MonadReader r m, Hbro.Gui.HasGUI r, MonadError Text m, ToSet Text tags) => FilePath -> tags -> m ()
add' file tags = do
    uri <- getCurrentURI
    void . addCustom file $ Entry uri (toSet tags)

-- | Add a custom entry to bookmarks
addCustom :: (BaseIO m, MonadError Text m)
          => FilePath      -- ^ Bookmarks file
          -> Entry         -- ^ Custom bookmark entry
          -> m ()
addCustom file newEntry = io $ withFile file AppendMode (`hPutStrLn` describe newEntry)

-- | Open a dmenu with all (sorted alphabetically) bookmarks entries, and return the user's selection, if any.
select :: (ControlIO m, MonadError Text m)
       => [Text]         -- ^ dmenu's commandline options
       -> m URI
select dmenuOptions = (`select'` dmenuOptions) =<< getBookmarksFile

-- | Like 'select', but you can specify the bookmarks file path
select' :: (ControlIO m, MonadError Text m) => FilePath -> [Text] -> m URI
select' file dmenuOptions = do
    maybe (throwError "ERROR") return . parseURIReference . unpack . lastDef "" . words =<< dmenu dmenuOptions . unlines . sort . ordNub . (map reformat) . lines =<< readFile file

reformat :: Text -> Text
reformat line = unwords $ tags' ++ [uri]
  where
    uri:tags = words line
    tags'    = sort $ map (("[" ++) . (++ "]")) tags

-- | Open a dmenu with all (sorted alphabetically) bookmarks tags, and return the user's selection, if any.
selectByTag :: (ControlIO m, MonadError Text m)
          => [Text]          -- ^ dmenu's commandline options
          -> m [URI]
selectByTag dmenuOptions = (`selectByTag'` dmenuOptions) =<< getBookmarksFile

-- | Like 'selectByTag', but you can specify the bookmarks file path
selectByTag' :: (ControlIO m, MonadError Text m)
          => FilePath          -- ^ Bookmarks' database file
          -> [Text]            -- ^ dmenu's commandline options
          -> m [URI]
selectByTag' file dmenuOptions = do
-- Read bookmarks file
    result <- readFile file

    entries <- mapM (either (throwError . tshow) return . runParser entry () "(unknown)") . lines $ result
    let tags = unlines . Set.toList . foldl' Set.union Set.empty $ map _tags entries

-- Let user select a tag
    (map _uri) . (\t -> filter (hasTag t) entries) <$> dmenu dmenuOptions tags

--
--popOldest :: PortableFilePath -> Text -> IO (Maybe URI)
--popOldest file tags = do

-- Return a random Bookmark entry with a given tag, while removing it from bookmarks.
-- popRandom :: PortableFilePath
--           -> Text
--           -> IO (Maybe URI)
-- popRandom file tags = do
--     file'  <- resolve file
--     result <- try . readFile $ file'
--     file'' <- either (\e -> errorHandler file' e >> return Nothing) (\x -> return $ Just x) result

--     forM_ file'' $ \f -> do
--         let selection = choiceExtract . lines $ f
--         forM_ selection $ \s -> do
--             (newLines, value) <- runRVar s DevURandom

--             renameFile file' (file' ++ ".old")
--             writeFile file' . unlines . ordNub $ newLines

--             return . parseURIReference . last . words $ value


-- | Remove all bookmarks entries matching the given tag.
deleteByTag :: (ControlIO m, MonadError Text m)
          => [Text]          -- ^ dmenu's commandline options
          -> m ()
deleteByTag dmenuOptions = (`deleteByTag'` dmenuOptions) =<< getBookmarksFile

-- | Like 'selectByTag', but you can specify the bookmarks file path
deleteByTag' :: (ControlIO m, MonadError Text m)
              => FilePath          -- ^ Bookmarks' database file
              -> [Text]            -- ^ dmenu's commandline options
              -> m ()
deleteByTag' file dmenuOptions = do
    result <- readFile file

    entries <- mapM (either (throwError . tshow) return . runParser entry () "(unknown)") . lines $ result
    let tags = unlines . Set.toList . (foldl' Set.union Set.empty) $ map _tags entries

    tag <- dmenu dmenuOptions tags
    writeFile (file <.> "old") $ unlines (describe <$> entries)
    writeFile file $ (unlines . map describe . (filter (not . (hasTag tag)))) entries