blob: 5ddf2c6ca2c0c3f65fce901a49738820ae51b1bc (
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
95
96
97
98
99
100
101
102
|
{-# LANGUAGE OverloadedStrings #-}
module Much.API (module Much.API) where
import Control.Concurrent
import Control.Exception (catch, finally, throwIO)
import Control.Monad.IO.Class
import Data.Function ((&))
import Data.Proxy (Proxy)
import Data.Tree.Zipper qualified as Z
import Much.API.Config as Much.API
import Much.Event
import Much.State
import Much.TreeView
import Network.Socket
import Network.Wai
import Network.Wai.Handler.Warp
import Notmuch.Class
import Notmuch.Message
import Servant
import System.IO.Error (isDoesNotExistError)
import System.Posix.Files (removeLink)
type API =
"current" :> (
"part" :> Get '[PlainText] String
:<|>
"query" :> Get '[PlainText] String
)
api :: Proxy API
api = Proxy
main :: Config -> (Event -> IO ()) -> IO ()
main Config{socketPath} putEvent = do
sock <- socket AF_UNIX Stream defaultProtocol
removeIfExists socketPath
bind sock $ SockAddrUnix socketPath
listen sock maxListenQueue
let settings = defaultSettings
& setPort 0
runSettingsSocket settings sock app `finally` closeSocket sock
where
app :: Application
app = serve api server
server :: Server API
server =
servePart
:<|>
serveQuery
servePart :: Handler String
servePart = do
q <- liftIO getState
case searchPart (Z.label (cursor q)) of
Just i -> return (show i <> "\n")
Nothing -> throwError err404
serveQuery :: Handler String
serveQuery = do
q <- liftIO getState
return $ (searchQuery $ Z.label $ cursor q) <> "\n"
getState :: IO State
getState = do
v <- newEmptyMVar
putEvent $ EStateGet $ putMVar v
takeMVar v
searchPart :: TreeView -> Maybe Int
searchPart = \case
TVMessagePart _ i -> Just (partID i)
_ -> Nothing
searchQuery :: TreeView -> String
searchQuery = \case
TVMessage m -> notmuchId m
TVMessageHeaderField m _ -> notmuchId m
TVMessagePart m _ -> notmuchId m
TVMessageQuoteLine m _ _ _ -> notmuchId m
TVMessageRawLine m _ _ _ -> notmuchId m
TVMessageLine m _ _ _ -> notmuchId m
TVSearch s -> s
TVSearchResult r -> notmuchId r
removeIfExists :: FilePath -> IO ()
removeIfExists fileName = removeLink fileName `catch` handleExists
where handleExists e
| isDoesNotExistError e = return ()
| otherwise = throwIO e
closeSocket :: Socket -> IO ()
closeSocket sock = do
name <- getSocketName sock
close sock
case name of
SockAddrUnix path -> removeIfExists path
_ -> return ()
|
