From 8d5e610b4caee7cb184294ca22f527f9f6934b82 Mon Sep 17 00:00:00 2001
From: tv <tv@krebsco.de>
Date: Tue, 14 May 2019 22:51:18 +0200
Subject: Much.API: init

---
 much.cabal        |   5 +++
 src/Much/API.hs   | 104 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/Much/Core.hs  |   5 +++
 src/Much/Event.hs |   4 ++-
 src/Much/State.hs |   4 +++
 5 files changed, 121 insertions(+), 1 deletion(-)
 create mode 100644 src/Much/API.hs

diff --git a/much.cabal b/much.cabal
index b0cdec9..935f148 100644
--- a/much.cabal
+++ b/much.cabal
@@ -87,13 +87,16 @@ library
                  , filepath
                  , friendly-time
                  , hyphenation
+                 , http-types
                  , linebreak
+                 , network
                  , old-locale
                  , process
                  , random
                  , rosezipper
                  , safe
                  , scanner
+                 , servent-server
                  , split
                  , terminal-size
                  , text
@@ -102,5 +105,7 @@ library
                  , transformers-compat
                  , unix
                  , vector
+                 , wai
+                 , warp
   default-language: Haskell2010
   ghc-options: -O2 -Wall -threaded
diff --git a/src/Much/API.hs b/src/Much/API.hs
new file mode 100644
index 0000000..5810c92
--- /dev/null
+++ b/src/Much/API.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+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 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)
+import qualified Data.Tree.Zipper as Z
+
+
+type API =
+    "current" :> (
+        "part" :> Get '[PlainText] String
+      :<|>
+        "query" :> Get '[PlainText] String
+    )
+
+api :: Proxy API
+api = Proxy
+
+main :: (Event -> IO ()) -> IO ()
+main putEvent = do
+    sock <- socket AF_UNIX Stream defaultProtocol
+    let sockFile = "/home/tv/tmp/much/warp.sock" -- PID?
+    removeIfExists sockFile
+    bind sock $ SockAddrUnix sockFile
+    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
+        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 ()
diff --git a/src/Much/Core.hs b/src/Much/Core.hs
index 353f248..e6dec8a 100644
--- a/src/Much/Core.hs
+++ b/src/Much/Core.hs
@@ -5,9 +5,11 @@
 module Much.Core where
 
 import Much.Action
+import Much.API
 import Blessings.String (Blessings(Plain,SGR),pp)
 import Control.Concurrent
 import Control.Monad
+import Data.Functor
 import Data.Time
 import Much.Event
 import Much.RenderTreeView (renderTreeView)
@@ -123,6 +125,7 @@ runState q0 = do
 
     threadIds <- mapM forkIO
         [ forever $ scan stdin >>= putEvent . EScan
+        , Much.API.main putEvent
         ]
 
     winchHandler putEvent
@@ -173,6 +176,8 @@ processEvent q = \case
             { screenWidth = w, screenHeight = h
             , flashMessage = Plain $ "resize " <> show (w,h)
             }
+    EStateGet f ->
+        forkIO (f q) $> Right q
     ev ->
         return $ Right q
             { flashMessage = SGR [31,1] $ Plain $ "unhandled event: " <> show ev
diff --git a/src/Much/Event.hs b/src/Much/Event.hs
index 9842327..5edb5d2 100644
--- a/src/Much/Event.hs
+++ b/src/Much/Event.hs
@@ -1,6 +1,7 @@
 module Much.Event where
 
 import Blessings
+import Much.State
 import Scanner
 
 data Event =
@@ -8,5 +9,6 @@ data Event =
     EScan Scan |
     EShutdown |
     EReload |
-    EResize Int Int
+    EResize Int Int |
+    EStateGet (State -> IO ())
   deriving Show
diff --git a/src/Much/State.hs b/src/Much/State.hs
index a522e99..b09d544 100644
--- a/src/Much/State.hs
+++ b/src/Much/State.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
 module Much.State where
 
 import Blessings.String (Blessings)
@@ -40,3 +41,6 @@ data ColorConfig = ColorConfig
     , boringMessage :: Blessings String -> Blessings String
     , tagMap :: [(T.Text, Blessings String -> Blessings String)]
     }
+
+instance Show (State -> IO ()) where
+    show = const "λ"
-- 
cgit v1.2.3