{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Main where import qualified Data.Char as Char import qualified Data.Aeson as Aeson import Data.Default (def) import Data.Function ((&)) import qualified Data.List as List import Data.Text (Text) import Data.Maybe (catMaybes,fromMaybe,listToMaybe) import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Data.Text.Read as Text import qualified Data.Text.Encoding as Text import Control.Monad (forever) import Blessings.Text (Blessings(Plain,SGR),pp) import qualified Blessings.Internal as Blessings import Control.Concurrent --import Data.Time import qualified Data.Map as Map import Pager.Types import Scanner import System.IO import qualified System.Console.Terminal.Size as Term import System.Posix.Signals (Handler(Catch), Signal, installHandler, raiseSignal, sigINT) import Much.Screen (Screen(Screen), withScreen) import qualified Hack.Buffer as Buffer import Hack.Buffer (Buffer) --import XMonad.Aeson () --import XMonad.Web.Types () ----import qualified XMonad --import qualified XMonad.StackSet --import qualified XMonad.Web.Types --import qualified Sixel --import Sixel (PaletteColor) import State (State(..)) --import Graphics.X11.Xlib.Types (Dimension,Position,Rectangle(..)) --import qualified XMonad.Web.Types import qualified Pager.Rasterizer as Rasterizer import System.Environment (lookupEnv) -- begin http client --import Network.HTTP.Client --import Network.HTTP.Client.Internal (Connection, openSocketConnection, makeConnection) --import Network.Socket.ByteString (sendAll, recv) --import qualified Control.Exception as E --import qualified Network.Socket as NS import qualified Network.Socket as S import qualified Network.Socket.ByteString as SBS import Network.HTTP.Client --import Network.HTTP.Client.Internal (makeConnection) --import Network.HTTP.Types.Status (statusCode) -- end http client showText :: Show a => a -> Text showText = Text.pack . show -- TODO move to Buffer bufferLength :: Buffer -> Int bufferLength (ls, rs) = length ls + length rs insertChar :: Char -> Buffer -> Buffer insertChar c (ls, rs) = (ls <> [c], rs) insertString :: String -> Buffer -> Buffer insertString s (ls, rs) = (ls <> s, rs) (!!?) :: [a] -> Int -> Maybe a x !!? i | i >= 0 = listToMaybe (drop i x) _ !!? _ = Nothing lookupCursoredWorkspace :: State -> Maybe Workspace lookupCursoredWorkspace State{..} = flip Map.lookup workspaces =<< foundWorkspaces !!? workspaceCursor ---- XXX assumes that the cursor is already at the (cleared) input line ---- TODO renderInputLine looks like it wants to be -> VT () --renderInputLine :: Maybe Int -> Mode -> Buffer -> IO () --renderInputLine mb_cnt m (lhs, rhs) = do -- --clearLine -- XXX do we need this clearLine? -- renderRight $ -- SGR [30,1] $ -- Plain (show m) <> -- maybe Empty -- (("["<>) . (<>"]") . SGR [33,1] . Plain . show) -- mb_cnt -- renderLeft $ promptString m <> gaudySpecial [35] (lhs ++ rhs) -- moveCursorLeft $ length $ lit rhs -- -- --renderLeft :: Blessings String -> IO () --renderLeft = putStr . pp -- -- --renderRight :: Blessings String -> IO () --renderRight a = do -- saveCursor -- moveCursorRight 1024 -- XXX obviously, this is a hack..^_^ -- moveCursorLeft $ len a - 1 -- renderLeft a -- unsaveCursor -- end move to Buffer renderBuffer :: State -> Blessings Text renderBuffer State{buffer=(ls0,rs0)} = let ls = Text.pack ls0 rs = Text.pack rs0 in case Text.uncons rs of Just (c, rs') -> Plain ls <> SGR [48,5,200] (Plain $ Text.singleton c) <> Plain rs' Nothing -> let c = ' ' in Plain ls <> SGR [48,5,200] (Plain $ Text.singleton c) <> Plain rs data Event = --EFlash (Blessings Text) | EScan Scan | EShutdown | --EReload | EResize Int Int --EStateGet (State -> IO ()) deriving Show -- TODO handle exceptions / errors wmget :: Aeson.FromJSON a => Manager -> String -> IO (Maybe a) wmget manager path = do -- TODO check path is absolute let url = "http://localhost" <> path let request = parseRequest_ url response <- httpLbs request manager --putStrLn $ "wmget: The status code was: " ++ (show $ statusCode $ responseStatus response) return $ Aeson.decode $ responseBody response wmpost :: (Aeson.ToJSON a, Aeson.FromJSON b) => Manager -> String -> a -> IO (Maybe b) wmpost manager path content = do -- TODO check path is absolute let url = "http://localhost" <> path let request = (parseRequest_ url) { method = "POST", requestBody = RequestBodyLBS $ Aeson.encode content } response <- httpLbs request manager --putStrLn $ "wmpost: The status code was: " ++ (show $ statusCode $ responseStatus response) return $ Aeson.decode $ responseBody response --post path content = do -- -- TODO check path is absolute -- let url = "http://localhost" <> path -- let request = parseRequest_ { method = "POST", requestBody = RequestBodyLBS $ Aeson.encode content } -- httpLbs request manager -- TODO put displayNumber in some lib -- https://tronche.com/gui/x/xlib/display/opening.html (where's the manual in NixOS?) -- hostname:number.screen_number --displayNumber :: String -> Maybe Int --displayNumber = -- takeWhile Char.isDigit . dropWhile (==':') main :: IO () main = do -- TODO dedup with xmonad API display <- read . fromMaybe "0" . fmap (takeWhile Char.isDigit . dropWhile (==':')) <$> lookupEnv "DISPLAY" :: IO Int -- TODO use $XMONAD_CACHE_DIR -- API says: -- TODO runtimeDir instead of cacheDir cacheDir <- fromMaybe undefined <$> lookupEnv "XMONAD_CACHE_DIR" let xmonadSocketPath = cacheDir <> "/warp-" <> show display <> ".sock" manager <- newUnixDomainSocketManager xmonadSocketPath --response <- get "/state" Just workspaces <- wmget manager "/pager/state" :: IO (Maybe [Workspace]) --putStrLn $ "The status code was: " ++ (show $ statusCode $ responseStatus response) --let body = responseBody response ----print body --let Just XMonad.Web.Types.State{..} = Aeson.decode body :: Maybe (XMonad.Web.Types.State (XMonad.Web.Types.DummyLayout Text)) ----x <- getXMonadState --print (111 :: Int) --mapM_ (putStrLn . XMonad.StackSet.tag) (XMonad.Web.Types.s_workspaces state) --print (112 :: Int) --mapM_ (putStrLn . show . XMonad.StackSet.stack) (XMonad.Web.Types.s_workspaces state) --print (113 :: Int) --mapM_ (putStrLn . show . XMonad.StackSet.layout) (XMonad.Web.Types.s_workspaces state) --print (114 :: Int) --mapM_ (putStrLn . show) (XMonad.Web.Types.s_windows state) ----print (115 :: Int) ----print state --print (999 :: Int) let screen0 = Screen False NoBuffering (BlockBuffering $ Just 4096) [ 1000 -- X & Y on button press and release , 1005 -- UTF-8 mouse mode , 1047 -- use alternate screen buffer ] [ 25 -- hide cursor , 80 -- disable sixel scrolling ] withScreen screen0 $ \_ -> do (putEvent, getEvent) <- do v <- newEmptyMVar return (putMVar v, takeMVar v) let q1 = updateFoundWorkspaces $ def { manager = manager , termBorder = 2 -- TODO config , workspaces = let f workspace@Workspace{workspace_name} = ( workspace_name, workspace ) in Map.fromList (map f workspaces) } --windows = -- let -- f window@Window{window_id} = ( window_id, window ) -- in -- Map.fromList (map f s_windows) signalHandlers = [ (sigINT, putEvent EShutdown) , (28, winchHandler putEvent) ] installHandlers signalHandlers threadIds <- mapM forkIO [ forever $ scan stdin >>= putEvent . EScan ] winchHandler putEvent run getEvent q1 hPutStr stdout "Fin" mapM_ killThread threadIds run :: IO Event -> State -> IO () run getEvent = rec . Right where rec = \case Right q -> -- do --t <- getCurrentTime --let q' = q { now = t } redraw q >> getEvent >>= processEvent q >>= rec Left _q -> return () installHandlers :: [(Signal, IO ())] -> IO () installHandlers = mapM_ (\(s, h) -> installHandler s (Catch h) Nothing) processEvent :: State -> Event -> IO (Either State State) processEvent q = \case EScan (ScanKey s) -> do let key = Text.pack s (q', action) = keymap key q realizeAction = \case None -> return () Batch a1 a2 -> do realizeAction a1 realizeAction a2 FocusWorkspace name -> do -- TODO make quitting configurable with some "quit after change focus" option --jumpQndQuit :: State -> IO State --jumpQndQuit q@State{manager} = do -- case workspace_name <$> lookupCursoredWorkspace q of -- Just name -> do -- -- TODO response, TODO Cmd-like -- _ <- wmpost manager ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ()) -- raiseSignal sigINT -- return q -- -- Nothing -> -- return q _ <- wmpost (manager q') ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ()) raiseSignal sigINT -- TODO check for failures, and then Left instead of Right realizeAction action return $ Right q' EScan mouseInfo@ScanMouse{..} -> Right <$> mousemap mouseInfo q EShutdown -> return $ Left q EResize w h -> return $ Right q { termWidth = w, termHeight = h , flashMessage = Plain $ "resize " <> showText (w,h) , workspaceViewportHeight = newWorkspaceViewportHeight , workspaceViewportOffset = newWorkspaceViewportOffset } where -- TODO resizeWorkspaceViewport -- TODO what if h < 0? newWorkspaceViewportHeight = h - 2 {- input line + status line -} newWorkspaceViewportOffset = if newWorkspaceViewportHeight > workspaceViewportHeight q then max 0 $ workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight) --else if workspaceCursor q >= newWorkspaceViewportHeight + workspaceViewportOffset q then else if newWorkspaceViewportHeight <= workspaceCursor q - workspaceViewportOffset q then workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight) else workspaceViewportOffset q --if workspaceCursor q < workspaceViewportOffset q then -- workspaceCursor q --else if workspaceCursor q >= workspaceViewportOffset q + workspaceViewportHeight q then -- workspaceCursor q - workspaceViewportHeight q + 1 --else -- workspaceViewportOffset q -- negative ~ down, positive ~ up moveWorkspaceCursor :: Int -> State -> State moveWorkspaceCursor i q@State{..} = --case compare i 0 of -- LT -> moveWorkspaceCursorDown (-1) q -- GT -> moveWorkspaceCursorUp 1 q -- EQ -> q q { workspaceCursor = newWorkspaceCursor , workspaceViewportOffset = newWorkspaceViewportOffset } where newWorkspaceCursor = max 0 $ min (workspaceCursor + i) $ length foundWorkspaces - 1 -- TODO dedup with processEvent / EResize newWorkspaceViewportOffset = if newWorkspaceCursor < workspaceViewportOffset then newWorkspaceCursor else if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then newWorkspaceCursor - workspaceViewportHeight + 1 else workspaceViewportOffset --if newWorkspaceCursor < workspaceCursor then -- if newWorkspaceCursor < workspaceViewportOffset then -- newWorkspaceCursor -- TODO clamp or is it already? -- else -- workspaceViewportOffset --else if newWorkspaceCursor > workspaceCursor then -- if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then -- newWorkspaceCursor - workspaceViewportHeight + 1 -- else -- workspaceViewportOffset --else -- workspaceViewportOffset --workspaceCursorDelta = newWorkspaceCursor - workspaceCursor --workspaceViewportDelta = -- if isNewWorkspaceCursorOutOfViewport then -- workspaceCursorDelta -- else -- 0 -- --newWorkspaceViewportOffset = workspaceViewportOffset + workspaceViewportDelta --isNewWorkspaceCursorOutOfViewport = -- newWorkspaceCursor < workspaceViewportOffset || -- newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight -- --if newWorkspaceCursor < workspaceViewportOffset then -- -- workspaceViewportOffset - (workspaceCursor - newWorkspaceCursor) -- --else if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then -- -- workspaceViewportOffset + (newWorkspaceCursor - workspaceCursor) -- --else -- -- workspaceViewportOffset --if newWorkspaceCursor < workspaceCursor then -- if newWorkspaceCursor < workspaceViewportOffset then -- workspaceViewportOffset - (workspaceCursor - newWorkspaceCursor) -- else -- workspaceViewportOffset --else if newWorkspaceCursor > workspaceCursor then -- if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then -- workspaceViewportOffset + (newWorkspaceCursor - workspaceCursor) -- else -- workspaceViewportOffset --else -- workspaceViewportOffset setCount :: Int -> State -> State setCount i q = q { count = i } keymap :: Text -> State -> ( State, Action ) keymap s | [ "\ESC[4" , Text.decimal -> Right (termHeightPixels, "") , Text.unsnoc -> Just (Text.decimal -> Right (termWidthPixels, "") , 't') ] <- Text.split (==';') s = \q -> ( q { termHeightPixels, termWidthPixels } , None ) keymap s | [ "\ESC[6" , Text.decimal -> Right (charHeight, "") , Text.unsnoc -> Just (Text.decimal -> Right (charWidth, "") , 't') ] <- Text.split (==';') s = \q -> ( q { charHeight, charWidth } , None ) -- Up keymap "\ESC[A" = \q@State{..} -> ( moveWorkspaceCursor count q & setCount 1 , None ) -- Down keymap "\ESC[B" = \q@State{..} -> ( moveWorkspaceCursor (-count) q & setCount 1 , None ) -- PgUp keymap "\ESC[5~" = \q@State{..} -> ( moveWorkspaceCursor (count * max 1 (workspaceViewportHeight - 1)) q & setCount 1 , None ) -- PgDn keymap "\ESC[6~" = \q@State{..} -> ( moveWorkspaceCursor (-count * max 1 (workspaceViewportHeight - 1)) q & setCount 1 , None ) keymap "\ESCOP" = \q -> (setCount 1 q, mempty) keymap "\ESCOQ" = \q -> (setCount 2 q, mempty) keymap "\ESCOR" = \q -> (setCount 3 q, mempty) keymap "\ESCOS" = \q -> (setCount 4 q, mempty) keymap "\ESC[15~" = \q -> (setCount 5 q, mempty) keymap "\ESC[17~" = \q -> (setCount 6 q, mempty) keymap "\ESC[18~" = \q -> (setCount 7 q, mempty) keymap "\ESC[19~" = \q -> (setCount 8 q, mempty) keymap "\ESC[20~" = \q -> (setCount 9 q, mempty) keymap "\ESC[21~" = \q -> (setCount 0 q, mempty) -- Right keymap "\ESC[C" = \q@State{..} -> ( q { buffer = Buffer.move Buffer.CharsForward 1 buffer } , None ) -- Left keymap "\ESC[D" = \q@State{..} -> ( q { buffer = Buffer.move Buffer.CharsBackward 1 buffer } , None ) -- Home keymap "\ESC[H" = \q@State{..} -> ( q { ex_offsetY = ex_offsetY - 1 } , None ) -- End keymap "\ESC[F" = \q@State{..} -> ( q { ex_offsetY = ex_offsetY + 1 } , None ) keymap "\b" = \q@State{..} -> ( updateFoundWorkspaces q { buffer = Buffer.delete Buffer.CharsBackward 1 buffer } , None ) keymap "\n" = \q -> ( q , foldMap (FocusWorkspace . workspace_name) (lookupCursoredWorkspace q) ) keymap s | Text.length s == 1 , [c] <- Text.unpack s , Char.isPrint c = \q0 -> let q = updateFoundWorkspaces q0 { buffer = insertChar c (buffer q0) } in ( q , -- TODO make the jump-when-exactly-one-match behavior configurable case lookupCursoredWorkspace q of Just Workspace{workspace_focused,workspace_name} -> if length (foundWorkspaces q) == 1 then -- TODO if length foundWorkspaces == 2 and one of the workspaces is -- focused, then jump to the other if not workspace_focused then FocusWorkspace workspace_name else mempty else mempty Nothing -> mempty ) keymap s = \q -> ( displayKey s q , mempty ) updateFoundWorkspaces :: State -> State updateFoundWorkspaces q@State{..} = q { foundWorkspaces = newFoundWorkspaces , workspaceCursor = max 0 $ min workspaceCursor $ length newFoundWorkspaces - 1 } where -- TODO filter out current workspace f = Text.isPrefixOf (Text.pack (Buffer.showBuffer buffer)) newFoundWorkspaces = map fst . List.sortOn (workspaceSortKey . snd) . filter (f . fst) . Map.toList $ workspaces -- smaller is "more important" workspaceSortKey ws@Workspace{..} = ( not $ isWorkspaceUrgent ws -- urgent workspaces are most importsnt , workspace_focused -- focused workspace is least important , List.null workspace_windows -- non-empty workspaces are more important , workspace_name -- sort by name ) isWorkspaceUrgent = List.any window_urgent . workspace_windows mousemap :: Scan -> State -> IO State --mousemap ScanMouse{mouseButton=1,mouseY=y} = defaultMouse1Click y --mousemap ScanMouse{mouseButton=3,mouseY=y} = \q -> defaultMouse1Click y q >>= toggleFold --mousemap ScanMouse{mouseButton=4} = moveTreeDown 3 --mousemap ScanMouse{mouseButton=5} = moveTreeUp 3 --mousemap ScanMouse{mouseButton=0} = return mousemap info = displayMouse info displayKey :: Text -> State -> State displayKey s q = q { flashMessage = Plain $ showText s } displayMouse :: Scan -> State -> IO State displayMouse info q = return q { flashMessage = SGR [38,5,202] $ Plain $ showText info } winchHandler :: (Event -> IO ()) -> IO () winchHandler putEvent = do -- TODO use events --hPutStr stdout "\ESCc" -- TODO only on change hPutStr stdout "\ESC[14t" -- query terminal width / height (in pixels) hPutStr stdout "\ESC[16t" -- query character width / height Term.size >>= \case Just Term.Window {Term.width = w, Term.height = h} -> putEvent $ EResize w h Nothing -> return () redraw :: State -> IO () redraw q@State{..} = do Text.hPutStr stdout . pp $ "\ESC[H" <> (mintercalate "\n" $ map eraseRight2 $ render0 q) -- XXX this has no effect when sixel scrolling is disabled -- <> "\ESC[5;" <> Plain (showText $ maxWidth + 2) <> "H" <> workspacePreview hFlush stdout where workspacePreview :: Blessings Text workspacePreview = let previewWidth = paddingRight * charWidth :: Int previewHeight = round $ (fromIntegral previewWidth :: Double) / fromIntegral screenWidth * fromIntegral screenHeight :: Int previewGeometry = Geometry { geometry_width = fromIntegral previewWidth , geometry_height = fromIntegral previewHeight , geometry_x = fromIntegral $ termWidthPixels - previewWidth , geometry_y = fromIntegral $ ex_offsetY } --windows = -- case foundWorkspaces of -- [] -> [] -- _ -> -- let -- cursoredWorkspace = foundWorkspaces !! workspaceCursor -- TODO safe -- in -- fromMaybe [] $ Map.lookup cursoredWorkspace workspaces in --case foundWorkspaces of -- [] -> "" -- _ -> -- let -- cursoredWorkspace = foundWorkspaces !! workspaceCursor -- TODO safe -- ws = fromMaybe emptyWorkspace $ Map.lookup cursoredWorkspace workspaces -- -- TODO def -- emptyWorkspace = Workspace -- { workspace_geometry = Geometry 0 0 0 0 -- , workspace_focused = False -- , workspace_name = "" -- , workspace_windows = [] -- } -- in -- Plain $ Text.decodeUtf8With (\_ _ -> Nothing) $ Rasterizer.renderWorkspacePreview previewGeometry q ws fromMaybe "" (renderWorkspacePreview previewGeometry q <$> lookupCursoredWorkspace q) renderWorkspacePreview :: Geometry -> State -> Workspace -> Blessings Text renderWorkspacePreview geometry qq = Plain . Text.decodeUtf8With (\_ _ -> Nothing) . Rasterizer.renderWorkspacePreview geometry qq maxWidth = termWidth - paddingRight -- This is not just padding right, but also the width of the workspace preview paddingRight = 10 {- #paddingRight put into state -} eraseRight2 s = if Blessings.length s < maxWidth then s <> SGR [38,5,234] (Plain $ Text.pack $ replicate (maxWidth - Blessings.length s) '@') else s --sub x x' c = if c == x then x' else c --eraseRight s = -- if Blessings.length s < termWidth -- then s <> "\ESC[K" -- else s render0 :: State -> [Blessings Text] render0 q@State{..} = map (Blessings.take maxWidth) ((shownWorkspacesPadding <> shownWorkspaces) `join` (shownWindowsPadding <> fromMaybe mempty shownWindows)) <> -- debug workspace viewport [SGR [38,5,147] "> " <> renderBuffer q] <> [Blessings.take termWidth $ SGR [38,5,242] flashMessage <> Plain (showText count)] where maxWidth = termWidth - paddingRight -- This is not just padding right, but also the width of the workspace preview paddingRight = 10 {- #paddingRight put into state -} -- for debugging workspace viewport -- debug = Plain (showText (workspaceViewportOffset, workspaceViewportHeight, workspaceCursor) n = termHeight - 2 {- input line + status line -} shownWorkspaces :: [Blessings Text] shownWorkspaces = reverse $ map showWorkspace $ zip [workspaceViewportOffset..] (take n (drop workspaceViewportOffset $ foundWorkspaces')) where foundWorkspaces' = catMaybes $ map (flip Map.lookup workspaces) foundWorkspaces shownWorkspacesPadding = replicate (n - length shownWorkspaces) (SGR [38,5,234] "~") showWorkspace :: (Int, Workspace) -> Blessings Text showWorkspace (index, Workspace{..}) = let --windows = maybe [] workspace_windows $ Map.lookup name workspaces isUrgent = any window_urgent workspace_windows (ls,rs) = Text.splitAt (bufferLength buffer) workspace_name marker = if index == workspaceCursor then SGR [38,5,177] "> " else Plain " " fgColor = if isUrgent then SGR [38,5,196] else if workspace_focused then SGR [38,5,238] else if length workspace_windows == 0 then SGR [38,5,246] else id in marker <> SGR [48,5,023] (fgColor (Plain ls)) <> fgColor (Plain rs) --cursoredWorkspace = foundWorkspaces !! workspaceCursor -- TODO safe --cursoredWorkspaceWindows = maybe [] workspace_windows $ Map.lookup cursoredWorkspace workspaces shownWindows :: Maybe [Blessings Text] --shownWindows = take (length shownWorkspaces) $ map (SGR [38,5,236] . Plain . window_title) cursoredWorkspaceWindows shownWindows = take (length shownWorkspaces) . map (SGR [38,5,236] . Plain . window_title) . workspace_windows <$> lookupCursoredWorkspace q shownWindowsPadding = replicate (n - maybe 0 length shownWindows) (SGR [38,5,234] "~") join :: [Blessings Text] -> [Blessings Text] -> [Blessings Text] join ls rs = zipWith (<>) lsFilled rs where --rsTruncated = map (Blessings.take 10) rs lsWidth = maximum $ map Blessings.length ls lsFilled = map (lsFill lsWidth) ls lsFill n s = if Blessings.length s < n then s <> SGR [38,5,234] (Plain (Text.pack (replicate (n - Blessings.length s) '#') <> Text.singleton '|')) else s <> SGR [38,5,234] (Plain (Text.singleton '|')) --joinColumns :: [Blessings.Text] -> [Blessings.Text] -> [Blessings.Text] --joinColumns ls rs = mintercalate :: Monoid b => b -> [b] -> b mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t mintercalate _ [] = mempty -- begin http client --getXMonadState :: IO (Maybe (XMonad.Web.Types.State (XMonad.Web.Types.DummyLayout Text))) --getXMonadState = do -- mgr <- newManager defaultManagerSettings { -- managerRawConnection = createUnixConnection -- } -- req <- parseUrl "http://localhost/state" -- res <- httpLbs req mgr -- let body = responseBody res -- return $ Aeson.decode body --createUnixConnection :: IO (Maybe NS.HostAddress -> String -> Int -> IO Connection) --createUnixConnection = return $ \_ _ _ -> openUnixConnection xmonadSocketPath -- --openUnixConnection :: String -> IO Connection --openUnixConnection addr = E.bracketOnError -- (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) -- (NS.close) -- $ \sock -> do -- NS.connect sock sockAddr -- mySocketConnection sock chunksize -- where -- sockAddr = NS.SockAddrUnix addr -- chunksize = 8192 -- --------------------------------------------------------------------------------- ---- Copied from http-client --------------------------------------------------------------------------------- -- --mySocketConnection :: NS.Socket -> Int -> IO Connection --mySocketConnection socket chunksize = makeConnection -- (recv socket chunksize) -- (sendAll socket) -- (NS.close socket) newUnixDomainSocketManager :: FilePath -> IO Manager newUnixDomainSocketManager path = do let mSettings = defaultManagerSettings { managerRawConnection = return $ openUnixSocket path } newManager mSettings where openUnixSocket filePath _ _ _ = do s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol S.connect s (S.SockAddrUnix filePath) makeConnection (SBS.recv s 8096) (SBS.sendAll s) (S.close s) -- end http client