summaryrefslogtreecommitdiffstats
path: root/app/Settings.hs
blob: 39e8e35148b707e5c1e28c093b6f7b31fb822683 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Settings
  ( Settings (..),
    readSettings,
    writeSettings,
    SuggestedTag (..),
  )
where

import Data.Aeson qualified as A
import Data.Function (on)
import Data.List (nub)
import Data.Text qualified as T
import Data.Yaml (decodeFileThrow, encodeFile)
import GHC.Generics (Generic)
import System.Directory (doesFileExist)
import System.Environment.XDG.BaseDir (getSystemConfigFiles, getUserConfigFile)
import Text.RE.TDFA.Text qualified as R

data Settings = Settings
  { suggestedTags :: [SuggestedTag]
  }
  deriving (Show, Generic)

instance Semigroup Settings where
  a <> b =
    Settings
      { suggestedTags = nub (a.suggestedTags <> b.suggestedTags)
      }

instance Monoid Settings where
  mempty =
    Settings
      { suggestedTags =
          [ -- TODO Add `SuggestedTagByDate`
            --
            -- By having a dedicated constructor for dates wie can take the following improvements into account:
            --
            -- -   date formats that spell out the month name, ie. `1 Januar 1970` or `1 Jan 1970`
            -- -   perform minor corrections on OCR, ie. parse `0 1.01.1970`
            SuggestTagByRE "createdAt" [R.re|[0-9]{2}\.[0-9]{2}\.[0-9]{4}|],
            SuggestTagByTags "correspondent"
          ]
      }

instance A.FromJSON Settings

instance A.ToJSON Settings

data SuggestedTag
  = SuggestTagByRE T.Text R.RE
  | SuggestTagByTags T.Text
  deriving (Show, Generic, Eq)

instance Show R.RE where
  show = R.reSource

instance Eq R.RE where
  (==) = (==) `on` show

instance A.FromJSON SuggestedTag

instance A.ToJSON SuggestedTag

instance A.FromJSON R.RE where
  parseJSON = A.withText "regular expression (POSIX)" (R.compileRegex . T.unpack)

instance A.ToJSON R.RE where
  toJSON = A.toJSON . R.reSource

readSettings :: IO Settings
readSettings =
  fmap mconcat
    . mapM
      ( \fp ->
          doesFileExist fp >>= \case
            True -> decodeFileThrow fp
            False -> pure mempty
      )
    =<< concat
      <$> sequence
        [ getSystemConfigFiles "apaperless" "settings.yaml",
          ((: []) <$> getUserConfigFile "apaperless" "settings.yaml"),
          pure ["apaperless.yaml"]
        ]

writeSettings :: FilePath -> Settings -> IO ()
writeSettings =
  encodeFile