wipwip

1 files changed, 693 insertions, 0 deletions

diff --git a/src/main.hs b/src/main.hs
new file mode 100644
index 0000000..7d956a4
--- /dev/null
+++ b/src/main.hs
@@ -0,0 +1,693 @@
+{-# 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.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@State{..} = \case
+    EScan (ScanKey s) ->
+        Right <$> keymap (Text.pack s) 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 then
+            max 0 $ workspaceViewportOffset - (newWorkspaceViewportHeight - workspaceViewportHeight)
+          else if workspaceCursor < newWorkspaceViewportHeight + workspaceViewportOffset then
+            workspaceViewportOffset
+          else
+            workspaceViewportOffset + (workspaceViewportHeight - newWorkspaceViewportHeight)
+
+
+keymap :: Text -> State -> IO State
+
+keymap s
+      | [ "\ESC[4"
+        , Text.decimal -> Right (termHeightPixels, "")
+        , Text.unsnoc -> Just (Text.decimal -> Right (termWidthPixels, "") , 't')
+        ] <- Text.split (==';') s
+      = \q ->
+    return q { termHeightPixels, termWidthPixels }
+
+keymap s
+      | [ "\ESC[6"
+        , Text.decimal -> Right (charHeight, "")
+        , Text.unsnoc -> Just (Text.decimal -> Right (charWidth, "") , 't')
+        ] <- Text.split (==';') s
+      = \q ->
+    return q { charHeight, charWidth }
+
+-- Up
+keymap "\ESC[A" = \q@State{..} ->
+    let
+      newWorkspaceCursor = max 0 $ min (workspaceCursor + 1) $ length foundWorkspaces - 1
+      newWorkspaceViewportOffset =
+        -- TODO dedup with processEvent / EResize
+        if newWorkspaceCursor < workspaceViewportOffset + workspaceViewportHeight then
+          workspaceViewportOffset
+        else
+          workspaceViewportOffset + (newWorkspaceCursor - workspaceCursor)
+    in
+    return q
+      { workspaceCursor = newWorkspaceCursor
+      , workspaceViewportOffset = newWorkspaceViewportOffset
+      }
+
+-- Down
+keymap "\ESC[B" = \q@State{..} ->
+    --return q { workspaceCursor = max 0 $ workspaceCursor - 1 }
+    let
+      newWorkspaceCursor = max 0 $ workspaceCursor - 1
+      newWorkspaceViewportOffset =
+        -- TODO dedup with processEvent / EResize
+        if newWorkspaceCursor >= workspaceViewportOffset then
+          workspaceViewportOffset
+        else
+          workspaceViewportOffset - (workspaceCursor - newWorkspaceCursor)
+    in
+    return q
+      { workspaceCursor = newWorkspaceCursor
+      , workspaceViewportOffset = newWorkspaceViewportOffset
+      }
+
+-- Right
+keymap "\ESC[C" = \q@State{..} ->
+    return q { buffer = Buffer.move Buffer.CharsForward 1 buffer }
+
+-- Left
+keymap "\ESC[D" = \q@State{..} ->
+    return q { buffer = Buffer.move Buffer.CharsBackward 1 buffer }
+
+-- Home
+keymap "\ESC[H" = \q@State{..} ->
+    return q { ex_offsetY = ex_offsetY - 1 }
+
+-- End
+keymap "\ESC[F" = \q@State{..} ->
+    return q { ex_offsetY = ex_offsetY + 1 }
+
+keymap "\b" = \q@State{..} ->
+    updateFoundWorkspaces <$> return q { buffer = Buffer.delete Buffer.CharsBackward 1 buffer }
+
+keymap "\n" =
+    jumpQndQuit
+
+keymap s
+      | Text.length s == 1
+      , [c] <- Text.unpack s
+      , Char.isPrint c
+      = \q@State{..} ->
+    return (updateFoundWorkspaces q { buffer = insertChar c buffer }) >>= \q@State{..} ->
+    -- TODO make the jump-when-exactly-one-match behavior configurable
+    if length foundWorkspaces == 1 then
+
+      -- TODO if length foundWorkspaces == 2 and one of the workspaces is
+      --      focused, then jump to the other
+
+      case workspace_focused <$> lookupCursoredWorkspace q of
+        Just False ->
+          jumpQndQuit q
+        _ ->
+          return q
+    else
+      return q
+
+keymap s =
+    displayKey s
+
+
+
+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
+
+    -- IfElse's Control.Monad.IfElse.awhenM:
+    --awhenM (workspace_name <$> lookupCursoredWorkspace) $ \name -> do
+    --  _ <- wmpost manager ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ())
+    --  raiseSignal sigINT
+    --return q
+
+
+updateFoundWorkspaces :: State -> State
+updateFoundWorkspaces q@State{..} =
+    q { foundWorkspaces = newFoundWorkspaces
+      , workspaceCursor = max 0 $ min workspaceCursor $ length newFoundWorkspaces - 1
+      }
+  where
+    -- TODO List.sortBy compareWorkspaces (requires workspaces to be something better than a string)
+    newFoundWorkspaces = filter f (Map.keys workspaces)
+    f = Text.isPrefixOf (Text.pack (Buffer.showBuffer buffer))
+
+
+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 -> IO State
+displayKey s q = return 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 q =
+        Plain . Text.decodeUtf8With (\_ _ -> Nothing) . Rasterizer.renderWorkspacePreview geometry q
+
+
+    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]
+  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