module Purebred (
module Types,
module Error,
module UI.Actions,
module UI.Index.Keybindings,
module UI.Mail.Keybindings,
module Graphics.Vty.Attributes,
Event(..),
Key(..),
Modifier(..),
Next,
AttrName,
on,
fg,
bg,
applyAttrMappings,
getDatabasePath,
defaultConfig,
solarizedDark,
mailTagAttr,
listStateSelectedAttr,
listStateToggledAttr,
listStateNewmailAttr,
(</>),
module Control.Lens,
genBoundary,
Mailbox(..),
AddrSpec(..),
Domain(..),
purebred,
sendmail) where
import UI.App (theApp, initialState)
import Purebred.System.Logging (setupLogsink)
import qualified Config.Dyre as Dyre
import qualified Control.DeepSeq
import Control.Monad ((>=>), void)
import Options.Applicative hiding (str)
import qualified Options.Applicative.Builder as Builder
import Data.List (elemIndex, isInfixOf, isPrefixOf)
import qualified Data.Text.Lazy as T
import System.Environment (lookupEnv)
import System.FilePath (dropTrailingPathSeparator, joinPath, splitPath)
import System.FilePath.Posix ((</>))
import System.Random (RandomGen, getStdGen, randomRs)
import Data.Version (showVersion)
import Paths_purebred (version, getLibDir)
import UI.Index.Keybindings
import UI.Mail.Keybindings
import UI.Actions
import UI.Status.Main (rescheduleMailcheck)
import Storage.Notmuch (getDatabasePath)
import Config.Main
(defaultConfig, solarizedDark, mailTagAttr, sendmail,
listStateSelectedAttr, listStateToggledAttr, listStateNewmailAttr)
import Types
import Error
import qualified Graphics.Vty
import Graphics.Vty.Attributes
import Graphics.Vty.Input.Events (Event(..), Key(..), Modifier(..))
import Brick.BChan (newBChan)
import Brick.Main (customMain)
import Brick.Types (Next)
import Brick.Util (on, fg, bg)
import Brick.AttrMap (AttrName, applyAttrMappings)
import Control.Lens ((&), _head, over, preview, set, view)
import Data.Text.Lens (packed)
import Data.MIME (Mailbox(..), AddrSpec(..), Domain(..))
data AppConfig = AppConfig
{ databaseFilepath :: Maybe String
, searchOverride :: Maybe String
, debugFile :: Maybe FilePath
}
appconfig :: Parser AppConfig
appconfig = AppConfig
<$> optional
( Builder.option Builder.str
( long "database"
<> metavar "DATABASE"
<> help "Filepath to notmuch database"
)
)
<*> optional
( Builder.option Builder.str
( long "search"
<> metavar "SEARCH-TERM"
<> help "Override the initial notmuch search"
)
)
<*> optional
( Builder.option Builder.str
( long "debug"
<> metavar "FILE"
<> help "Write debug information to FILE"
)
)
<* Builder.infoOption versionString
( long "version"
<> short 'v'
<> help "Print the Purebred version and exit"
)
versionString :: String
versionString = showVersion version
optParser :: ParserInfo AppConfig
optParser = info
(appconfig <**> helper)
(fullDesc
<> progDesc "purebred"
<> header ("a search based, terminal mail user agent - " <> versionString))
launch :: [String] -> UserConfiguration -> IO ()
launch ghcOpts cfg = do
opts <- execParser optParser
let
pre =
maybe id (set (confNotmuch . nmDatabase) . pure) (databaseFilepath opts)
. maybe id (set (confNotmuch . nmSearch)) (view packed <$> searchOverride opts)
b <- genBoundary <$> getStdGen
bchan <- newBChan 32
logSink <- setupLogsink (debugFile opts)
logSink (T.pack "Compile flags: " <> T.intercalate (T.pack " ") (T.pack <$> ghcOpts))
logSink (T.pack "Opened log file")
cfg' <- processConfig (bchan, b, logSink) (pre cfg)
s <- initialState cfg'
let buildVty = Graphics.Vty.mkVty Graphics.Vty.defaultConfig
initialVty <- buildVty
let query = view (confNotmuch . nmHasNewMailSearch) cfg'
delay = view (confNotmuch . nmHasNewMailCheckDelay) cfg'
dbpath = view (confNotmuch . nmDatabase) cfg'
maybe (pure ()) (rescheduleMailcheck bchan dbpath query) delay
void $ customMain initialVty buildVty (Just bchan) (theApp s) s
processConfig
:: InternalConfigurationFields
-> UserConfiguration
-> IO InternalConfiguration
processConfig z = fmap (set confExtra z . Control.DeepSeq.force) . unIO
where
unIO =
(confNotmuch . nmDatabase) id
>=> confEditor id
>=> (confFileBrowserView . fbHomePath) id
boundaryChars :: String
boundaryChars = ['0'..'9'] <> ['a'..'z'] <> ['A'..'Z'] <> "'()+_,-./:=?"
genBoundary :: RandomGen g => g -> String
genBoundary = filter isBoundaryChar . randomRs (minimum boundaryChars, maximum boundaryChars)
where
isBoundaryChar = (`elem` boundaryChars)
guessPackageArgs :: FilePath -> [String]
guessPackageArgs dir =
let
path = dropTrailingPathSeparator <$> splitPath dir
reversedPath = case reverse path of
("lib" : xs) -> xs
xs -> xs
isCabalStore = [".cabal", "store"] `isInfixOf` path
packageId =
let
f s
| isCabalStore && ("purebred-" <> versionString <> "-") `isPrefixOf` s =
Just s
| otherwise = Nothing
in
maybe [] (\s -> ["-package-id", s]) (preview _head reversedPath >>= f)
packageDb
| isCabalStore =
maybe []
(\i -> ["-package-db", joinPath (take (i + 3) path <> ["package.db"])])
(elemIndex ".cabal" path)
| otherwise = []
in
packageDb <> packageId
purebred :: UserConfiguration -> IO ()
purebred cfg = do
configDir <- lookupEnv "PUREBRED_CONFIG_DIR"
ghcOptsEnv <- lookupEnv "GHCOPTS"
libdir <- getLibDir
let
ghcOpts = "-threaded" : maybe [] words ghcOptsEnv <> guessPackageArgs libdir
dyreParams = Dyre.defaultParams
{ Dyre.projectName = "purebred"
, Dyre.realMain = launch ghcOpts
, Dyre.showError = const error
, Dyre.configDir = pure <$> configDir
, Dyre.cacheDir = pure <$> configDir
, Dyre.ghcOpts = ghcOpts
}
Dyre.wrapMain dyreParams cfg