summaryrefslogtreecommitdiffstats
path: root/app/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'app/Main.hs')
-rw-r--r--app/Main.hs156
1 files changed, 105 insertions, 51 deletions
diff --git a/app/Main.hs b/app/Main.hs
index d10e407..11b7602 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -14,7 +14,7 @@ module Main where
import Control.Arrow (second)
import Control.Concurrent.ParallelIO.Local (parallel, withPool)
import Control.Exception (Exception, throw, throwIO)
-import Control.Monad (unless, when)
+import Control.Monad (forM, unless, when)
import Data.Aeson qualified as J
import Data.Attoparsec.Text qualified as A
import Data.ByteString.Lazy qualified as LB
@@ -38,6 +38,7 @@ import GHC.Generics (Generic)
import GHC.Records (HasField (..))
import Options.Applicative qualified as O
import Prompt qualified as P
+import Settings qualified as S
import System.Directory
import System.Environment (getEnv)
import System.FilePath
@@ -212,6 +213,9 @@ data Filter
main :: IO ()
main = do
+ settings <- S.readSettings
+ S.writeSettings "apaperless.yaml" settings
+
cwd <- getCurrentDirectory
setCurrentDirectory =<< getEnv "APAPERLESS_STORE_DIR"
ensureGit
@@ -219,11 +223,20 @@ main = do
ensureDir "index"
O.execParser (O.info (args O.<**> O.helper) O.idm) >>= \case
- Args {cmd = Consume {keep, inputs, force}} -> do
+ Args {cmd = Consume {keep, inputs, force, prompt}} -> do
indexNames <- parMapM (consume1 force keep) (map (cwd </>) inputs)
- documents <- mapM (readDocument . (<.> "json")) indexNames
- processDocuments documents
- mapM_ putStrLn indexNames
+ allDocs <- getDocuments
+ docs <- mapM (readDocument . (<.> "json")) indexNames
+ docs' <-
+ if prompt
+ then processDocumentsInteractively settings allDocs docs
+ else processDocuments settings allDocs docs
+ mapM_
+ ( \doc -> do
+ printf "%s\n" (takeBaseName doc.iFileName)
+ print doc.index.tags
+ )
+ docs'
Args {cmd = Edit {indexNames}} -> do
editDocuments
=<< mapM (readDocument . (<.> "json")) indexNames
@@ -244,13 +257,19 @@ main = do
=<< getDocuments
Args {cmd = List {filters, redo, todo = True}} -> do
doRedoIf filters redo
- processDocuments
- . applyFilters filters
- =<< getDocuments
+ allDocs <- getDocuments
+ _ <-
+ processDocumentsInteractively settings allDocs
+ . applyFilters filters
+ $ allDocs
+ pure ()
Args {cmd = Todo} -> do
- processDocuments
- . applyFilters [FilterByTag "todo"]
- =<< getDocuments
+ allDocs <- getDocuments
+ _ <-
+ processDocumentsInteractively settings allDocs
+ . applyFilters [FilterByTag "todo"]
+ $ allDocs
+ pure ()
Args {cmd = List {filters, redo, view = True}} -> do
doRedoIf filters redo
viewDocuments
@@ -279,6 +298,12 @@ data Document = Document
}
deriving (Show)
+instance HasField "oFilePath" Document FilePath where
+ getField doc = "originals" </> takeBaseName doc.iFileName <.> "pdf"
+
+instance HasField "iFilePath" Document FilePath where
+ getField doc = "index" </> doc.iFileName
+
tagValues :: [Document] -> M.Map T.Text (S.Set T.Text)
tagValues docs =
M.unionsWith S.union $
@@ -288,12 +313,6 @@ tagValues docs =
)
(S.toList (S.unions (map (.index.tags) docs)))
-instance HasField "oFilePath" Document FilePath where
- getField doc = "originals" </> takeBaseName doc.iFileName <.> "pdf"
-
-instance HasField "iFilePath" Document FilePath where
- getField doc = "index" </> doc.iFileName
-
getDocuments :: IO [Document]
getDocuments =
parMapM readDocument
@@ -316,20 +335,20 @@ applyFilters filters = filter (pred filters) `at` (.index.internalTags)
| null (g [f x]) = at g f xs
| otherwise = x : at g f xs
-processDocuments :: [Document] -> IO ()
-processDocuments docs =
- mapM_ (uncurry processDocument) (zip [1 :: Int ..] docs)
+processDocumentsInteractively :: S.Settings -> [Document] -> [Document] -> IO [Document]
+processDocumentsInteractively settings allDocs docs =
+ mapM (uncurry processDocumentInteractively) (zip [1 :: Int ..] docs)
where
numDocs = length docs
tagValues' = tagValues docs
- processDocument n (doc@Document {iFileName, index}) = do
+ processDocumentInteractively n doc = do
choice <-
P.prompt
( P.choice
( printf
"%s\n%s\n\n(%d/%d) Process this document?"
- (takeBaseName iFileName)
- index.shortText
+ (takeBaseName doc.iFileName)
+ doc.index.shortText
n
numDocs
)
@@ -346,12 +365,12 @@ processDocuments docs =
"f" -> do
printf "%s\n" (takeBaseName doc.iFileName)
printf "%s\n" doc.index.originalText
- processDocument n doc
- "p" -> tagDocument tagValues' doc
- "s" -> pure ()
+ processDocumentInteractively n doc
+ "p" -> tagDocumentInteractively settings allDocs doc
+ "s" -> pure doc
"v" -> do
viewDocuments [doc]
- processDocument n doc
+ processDocumentInteractively n doc
viewDocuments :: [Document] -> IO ()
viewDocuments docs =
@@ -389,38 +408,73 @@ editDocuments docs =
)
docs
-tagDocument :: M.Map T.Text (S.Set T.Text) -> Document -> IO ()
-tagDocument tagValues (Document {iFileName, index}) = do
- let createdAts =
- nub . catMaybes . map R.matchedText . R.allMatches $
- index.originalText
- R.*=~ [R.re|[0-9]{2}\.[0-9]{2}\.[0-9]{4}|]
- let suggestedTags =
- [ ( Tag "createdAt" (Just ""),
- map (Tag "createdAt" . Just) createdAts
- )
- {-,
- Tag "correspondent" (Just ""),
- Tag "invoice" Nothing,
- Tag "bill" Nothing-}
- ]
+suggestTags :: S.Settings -> [Document] -> Document -> IO [(Tag, [Tag])]
+suggestTags settings allDocs doc = do
+ forM settings.suggestedTags $ \suggestedTag -> do
+ case suggestedTag of
+ S.SuggestTagByRE tagName pattern -> do
+ let tagValues =
+ nub . catMaybes . map R.matchedText . R.allMatches $
+ doc.index.originalText
+ R.*=~ pattern
+ pure (Tag tagName (Just ""), map (Tag tagName . Just) tagValues)
+
+autoApplySuggestedTags :: [(Tag, [Tag])] -> [Tag]
+autoApplySuggestedTags =
+ mapMaybe
+ ( \(_, suggestedTags) ->
+ if null suggestedTags
+ then Nothing
+ else Just (head suggestedTags)
+ )
+
+processDocuments :: S.Settings -> [Document] -> [Document] -> IO [Document]
+processDocuments settings allDocs docs =
+ mapM processDocument docs
+ where
+ processDocument doc = do
+ tags <-
+ S.fromList . autoApplySuggestedTags
+ <$> suggestTags settings allDocs doc
+ let doc' =
+ doc
+ { index =
+ doc.index
+ { tags =
+ S.delete (Tag "todo" Nothing) (doc.index.tags `S.union` tags)
+ }
+ }
+ withGit do
+ J.encodeFile doc.iFilePath doc'.index
+ commitAll [doc.iFilePath] (printf "process %s (auto)" doc.iFilePath)
+ pure doc'
+
+tagDocumentInteractively :: S.Settings -> [Document] -> Document -> IO Document
+tagDocumentInteractively settings allDocs doc = do
+ suggestedTags <- suggestTags settings allDocs doc
tags <-
S.fromList . catMaybes
- <$> mapM (uncurry tagDocument') suggestedTags
- let tags' = S.delete (Tag "todo" Nothing) (index.tags `S.union` tags)
- index' = index {tags = tags'}
- iFilePath = "index" </> iFileName
+ <$> mapM (uncurry tagDocumentInteractively') suggestedTags
+ let doc' =
+ doc
+ { index =
+ doc.index
+ { tags =
+ S.delete (Tag "todo" Nothing) (doc.index.tags `S.union` tags)
+ }
+ }
withGit do
- J.encodeFile iFilePath index'
- commitAll [iFilePath] (printf "process %s (interactive)" iFilePath)
+ J.encodeFile doc.iFilePath doc'.index
+ commitAll [doc.iFilePath] (printf "process %s (interactive)" doc.iFilePath)
+ pure doc'
where
- tagDocument' :: Tag -> [Tag] -> IO (Maybe Tag)
- tagDocument' tag@(Tag tagKey Nothing) tags = do
+ tagDocumentInteractively' :: Tag -> [Tag] -> IO (Maybe Tag)
+ tagDocumentInteractively' tag@(Tag tagKey Nothing) tags = do
choice <-
P.prompt $
P.choice (printf "tag with %s?" tagKey) (("n" :: String) N.:| ["y"])
pure $ if (choice == "y") then Just tag else Nothing
- tagDocument' (Tag tagKey (Just _)) tags = do
+ tagDocumentInteractively' (Tag tagKey (Just _)) tags = do
tagValue <-
fmap T.pack . P.prompt $
P.string
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 05:01:06 +0000