xmonad-utils (empty) → 0.1
raw patch · 10 files changed
+667/−0 lines, 10 filesdep +X11dep +basedep +ghcsetup-changed
Dependencies added: X11, base, ghc, random, unix
Files
- LICENSE +27/−0
- Setup.lhs +4/−0
- src/Heval.hs +134/−0
- src/Hhp.hs +71/−0
- src/Hmanage.hs +45/−0
- src/Hslock.hsc +161/−0
- src/Hxput.hs +65/−0
- src/Hxsel.hs +42/−0
- src/Utils.hs +51/−0
- xmonad-utils.cabal +67/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Andrea Rossato++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMainWithHooks defaultUserHooks
+ src/Heval.hs view
@@ -0,0 +1,134 @@+-----------------------------------------------------------------------------+-- |+-- Module : Heval+-- Copyright : (c) Andrea Rossato+-- License : BSD3+--+-- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>+-- Stability : unstable+-- Portability : unportable+--+-- A simple evaluator used by a XMonad prompt+--+-----------------------------------------------------------------------------++module Main where++import GHC+import Panic+import DynFlags+import PackageConfig+import ErrUtils+import SrcLoc (SrcSpan)+import Outputable++import Control.Concurrent+import Control.Exception+import Data.Char+import Data.Dynamic+import Data.List+import Data.Maybe+import Prelude hiding (catch)+import System.Exit+import System.IO+import System.Random+import System.Posix.Resource+import System.Posix.Signals++ghcPath :: String+ghcPath = "/usr/lib/ghc-6.8.2"++myLog :: Severity -> SrcSpan -> PprStyle -> Message -> IO ()+myLog = \severity _ style msg ->+ case severity of+ SevInfo -> hPutStrLn stdout (show (msg style))+ SevFatal -> hPutStrLn stdout (show (msg style))+ _ -> hPutStrLn stdout (show (msg style))++rlimit :: ResourceLimit+rlimit = ResourceLimit 5++main :: IO ()+main = do+ setResourceLimit ResourceCPUTime (ResourceLimits rlimit rlimit)+ defaultErrorHandler defaultDynFlags $ do+ s <- getLine+ let exps = read s :: [String]+ ses <- initSession+ case exps of+ [] -> return ()+ (x:[]) -> runExp ses x+ xs -> do updateSession ses (init xs)+ runExp ses (last xs)++initSession :: IO Session+initSession = do+ ses <- newSession (Just ghcPath)+ df <- getSessionDynFlags ses+ setSessionDynFlags ses df {log_action = myLog }+ setContext ses [] [mkModule (stringToPackageId "base") (mkModuleName "Prelude")]+ return ses++updateSession :: Session -> [String] -> IO ()+updateSession ses l =+ mapM_ (runWithTimeOut 3 . flip (runStmt ses) SingleStep) l++exprToRun :: String -> IO String+exprToRun expr = do+ x <- sequence (take 3 (repeat $ getStdRandom (randomR (97,122)) >>= return . chr))+ return ("let { "++ x +++ " = " ++ expr +++ "\n} in take 2048 (show " ++ x +++ ")")++runWithTimeOut :: Int -> IO a -> IO a+runWithTimeOut to action = do+ t <- forkIO $ checkerThread+ res <- action+ killThread t+ return res+ where+ -- if this thread is not killed within t seconds it will raise the+ -- equivalent of a ^C+ checkerThread = do+ threadDelay (to * 1000000)+ -- FIXME+ hPutStrLn stdout "Interrupted."+ raiseSignal sigQUIT++runExp :: Session -> String -> IO ()+runExp ses (':':com) =+ specialCommand ses com+runExp ses s+ -- nothing: restart+ | s == "" || s == "\r" || s == "\n" = do+ return ()+ -- let: bind and update session+ | "let " `isPrefixOf` s = do+ runWithTimeOut 3 $ runStmt ses s SingleStep+ return ()+ -- something to eval+ | otherwise = do+ expr <- exprToRun s+ catch (go expr) (\e -> hPutStrLn stdout $ showException e)+ where+ go e = do+ str <- evalExpr ses e+ putStrLn str++evalExpr :: Session -> String -> IO String+evalExpr ses expr = do+ maybe_dyn <- dynCompileExpr ses expr+ case maybe_dyn of+ Just dyn -> return $ (fromMaybe "" (fromDynamic dyn :: Maybe String))+ _ -> do return []++-- special commands+specialCommand :: Session -> String -> IO ()+specialCommand _ com+ -- stop: stop server+ | "stop" `isPrefixOf` com = exitWith ExitSuccess+ -- quit: exit+ | "quit" `isPrefixOf` com = return ()+ | otherwise = return ()+
+ src/Hhp.hs view
@@ -0,0 +1,71 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hhp+-- Copyright : (c) Andrea Rossato+-- License : BSD3+-- +-- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>+-- Stability : unstable+-- Portability : unportable+--+-- Hides the pointer after some inactivity+--+-----------------------------------------------------------------------------++module Main where++import Prelude hiding (catch)+import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.Bits+import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras+import System.Exit++import Utils++main :: IO ()+main = do + dpy <- openDisplay ""+ let dflt = defaultScreen dpy+ rootw <- rootWindow dpy dflt+ waitForMotion dpy rootw++-- hides and grabs the pointer till the user moves it+hidePointer :: Display -> Window -> IO ()+hidePointer d w = do+ let em = buttonPressMask .|. pointerMotionMask+ cursor <- nullCursor d w+ ps <- grabPointer d w False em grabModeAsync + grabModeAsync w cursor currentTime+ when (ps /= grabSuccess) $ do+ waitASecond 1+ hidePointer d w+ allocaXEvent $ \e -> do+ maskEvent d em e+ ungrabPointer d currentTime+ waitForMotion d w++-- when the pointer is not moved a timer starts: after ten seconds, if+-- no motion interrupts the timer, the pointer is grabbed and made+-- invisible.+waitForMotion :: Display -> Window -> IO ()+waitForMotion d w = do+ mt <- myThreadId+ t <- forkIO (timer mt)+ block $ go t+ where+ -- interrupt the waiting for motion (and thus hide the pointer)+ timer t = do+ waitASecond 10+ throwTo t (ErrorCall "done")+ -- wait for the next motion, and restart the timer (?)+ stopAndWait t = do+ allocaXEvent $ maskEvent' d pointerMotionMask+ -- this seems to just suspend the timer...+ throwTo t (ExitException ExitSuccess)+ waitForMotion d w+ -- wait for a timer interrupt to hide the pointer+ go t = do+ catch (unblock $ stopAndWait t) (const $ hidePointer d w)
+ src/Hmanage.hs view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module : hmanage+-- Copyright : (c) Andrea Rossato+-- License : BSD3+-- +-- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>+-- Stability : unstable+-- Portability : unportable+--+-- Toggle override_redirect for an X window+--+-----------------------------------------------------------------------------+module Main where++import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras+import System.Environment++usage :: String -> String+usage n = "Usage: " ++ n ++ " manage/unmanage windowID"++main :: IO ()+main = do+ args <- getArgs+ pn <- getProgName+ let (win,ac) = case args of+ [] -> error $ usage pn+ w -> case (w !!0) of + "manage" -> (window, False)+ "unmanage" -> (window, True)+ _ -> error $ usage pn+ where window = case (w !! 1) of + [] -> error $ usage pn+ x -> read x :: Window+ dpy <- openDisplay ""+ unmapWindow dpy win+ sync dpy False+ allocaSetWindowAttributes $+ \attributes -> do+ set_override_redirect attributes ac+ changeWindowAttributes dpy win cWOverrideRedirect attributes+ mapWindow dpy win+ sync dpy False+
+ src/Hslock.hsc view
@@ -0,0 +1,161 @@+-----------------------------------------------------------------------------+-- |+-- Module : hslock+-- Copyright : (C) 2007 Andrea Rossato+-- License : BSD3+-- +-- Maintainer : andrea.rossato@unibz.it+-- Stability : unstable+-- Portability : unportable+--+-- A simple screen locker in Haskell+--+-- Works only with shadow passords and if set suid root+--+-- Compile with:+--+-- hsc2hs hslock.hsc+-- ghc --make hslock.hs -fglasgow-exts -lcrypt+--+-- Then, as root, set it suid root:+-- chmod u+s /path/to/hslock+-----------------------------------------------------------------------------++module Main where++import Control.Monad+import Control.Concurrent+import Data.IORef+import Data.Maybe+import Foreign.C+import Foreign+import System.Environment++import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras++import Utils++data Spwd = + Spwd { sp_namp :: CString+ , sp_pwdp :: CString+ }++#include "shadow.h"+#define _XOPEN_SOURCE+#include "unistd.h"++foreign import ccall unsafe "shodow.h getspnam"+ getspan :: CString -> IO (Ptr Spwd)++instance Storable Spwd where+ sizeOf _ = #{size struct spwd}+ alignment _ = alignment (undefined :: CInt)+ peek p = Spwd `fmap` #{peek struct spwd, sp_namp} p+ `ap` #{peek struct spwd, sp_pwdp} p+ poke p (Spwd n pw) = do+ #{poke struct spwd, sp_namp} p n+ #{poke struct spwd, sp_pwdp} p pw++getpass :: String -> IO Spwd+getpass name = + withCString name $ \ c_name -> do+ s <- throwIfNull "No user entry" $ getspan c_name+ peek s++foreign import ccall unsafe "unistd.h crypt"+ hcrypt :: CString -> CString -> IO CString++encrypt_pass :: String -> String -> IO String+encrypt_pass key salt = do+ withCString key $ \k -> + withCString salt $ \s -> do+ e <- hcrypt k s+ peekCString e++verifyPWD :: String -> String -> IO Bool+verifyPWD name pass = do+ u <- getpass name+ pw <- peekCString (sp_pwdp u)+ e <- encrypt_pass pass pw+ return (pw == e)++main :: IO ()+main = do+ s <- newIORef []+ d <- catch (getEnv "DISPLAY") ( const $ return [])+ dpy <- openDisplay d+ let dflt = defaultScreen dpy+ scr = defaultScreenOfDisplay dpy+ rootw <- rootWindow dpy dflt+ win <- mkUnmanagedWindow dpy scr rootw 0 0 (widthOfScreen scr) (heightOfScreen scr)+ selectInput dpy win keyPressMask+ mapWindow dpy win+ sync dpy False+ i <- grabInput dpy win+ if i == grabSuccess + then do+ eventLoop dpy s+ ungrabKeyboard dpy currentTime+ ungrabPointer dpy currentTime+ else putStrLn "Cannot grab the keyboard!"+ destroyWindow dpy win+ sync dpy False++grabInput :: Display -> Window -> IO GrabStatus+grabInput dpy win = do+ cursor <- nullCursor dpy win+ grabPointer dpy win False noEventMask grabModeAsync grabModeAsync win cursor currentTime+ ks <- grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime+ if (ks /= grabSuccess) + then do+ threadDelay (1*1000000)+ grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime+ else return ks++eventLoop :: Display -> IORef String -> IO ()+eventLoop d i = do+ (keysym,string,event) <- + allocaXEvent $ \e -> do + maskEvent d keyPressMask e+ ev <- getEvent e+ (ks,s) <- if ev_event_type ev == keyPress+ then lookupString $ asKeyEvent e+ else return (Nothing, "")+ return (ks,s,ev)+ handle d i (fromMaybe xK_VoidSymbol keysym,string) event++type KeyStroke = (KeySym, String)++handle :: Display -> IORef String -> KeyStroke -> Event -> IO ()+handle d i (ks,str) (KeyEvent {ev_event_type = t}) +-- Return: check password+ | t == keyPress && ks == xK_Return = do+ u <- getEnv "USER"+ p <- readIORef i+ b <- verifyPWD u p+ if b then return ()+ else modifyIORef i (\_ -> []) >> eventLoop d i+-- Escape: restart+ | t == keyPress && ks == xK_Escape = do+ modifyIORef i (\_ -> [])+ eventLoop d i+-- empty string -> loop+ | t == keyPress && str == "" = eventLoop d i+-- something to save+ | otherwise = do+ modifyIORef i (\s -> s ++ str)+ eventLoop d i+handle d i _ _ = eventLoop d i++mkUnmanagedWindow :: Display -> Screen -> Window -> Position+ -> Position -> Dimension -> Dimension -> IO Window+mkUnmanagedWindow dpy scr rw x y w h = do+ let visual = defaultVisualOfScreen scr+ attrmask = cWOverrideRedirect .|. cWBackPixel+ allocaSetWindowAttributes $+ \attributes -> do+ set_override_redirect attributes True+ set_background_pixel attributes $ blackPixel dpy (defaultScreen dpy)+ createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr)+ inputOutput visual attrmask attributes
+ src/Hxput.hs view
@@ -0,0 +1,65 @@+-----------------------------------------------------------------------------+-- |+-- Module : hxput+-- Copyright : (c) Andrea Rossato, Matthew Sackman+-- License : BSD3+--+-- Maintainer : Matthew Sackman <matthew@wellquite.org>+-- Stability : unstable+-- Portability : unportable+--+-- Sets the mouse selection+--+-----------------------------------------------------------------------------++module Main where++import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras+import System.Exit (exitWith, ExitCode(..))+import System.Environment++import Data.Char++main :: IO ()+main = do+ (text:_) <- getArgs+ dpy <- openDisplay ""+ let dflt = defaultScreen dpy+ rootw <- rootWindow dpy dflt+ win <- createSimpleWindow dpy rootw 0 0 1 1 0 0 0+ p <- internAtom dpy "PRIMARY" True+ ty <- internAtom dpy "UTF8_STRING" False+ xSetSelectionOwner dpy p win currentTime+ winOwn <- xGetSelectionOwner dpy p+ if winOwn == win+ then do allocaXEvent $ processEvent dpy ty text+ destroyWindow dpy win+ exitWith ExitSuccess+ else do putStrLn "Unable to obtain ownership of the selection"+ destroyWindow dpy win+ exitWith (ExitFailure 1)++processEvent :: Display -> Atom -> [Char] -> XEventPtr -> IO a+processEvent dpy ty text e = do+ nextEvent dpy e+ ev <- getEvent e+ if ev_event_type ev == selectionRequest+ then do print ev+ -- selection == eg PRIMARY+ -- target == type eg UTF8+ -- property == property name or None+ allocaXEvent $ \replyPtr -> do+ changeProperty8 (ev_event_display ev)+ (ev_requestor ev)+ (ev_property ev)+ ty+ propModeReplace+ (map (fromIntegral . ord) text)+ setSelectionNotify replyPtr (ev_requestor ev) (ev_selection ev) (ev_target ev) (ev_property ev) (ev_time ev)+ sendEvent dpy (ev_requestor ev) False noEventMask replyPtr+ sync dpy False+ putStrLn "Sent"+ else do putStrLn "Unexpected Message Received"+ print ev+ processEvent dpy ty text e
+ src/Hxsel.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- Module : hxsel+-- Copyright : (c) Andrea Rossato+-- License : BSD3+--+-- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>+-- Stability : unstable+-- Portability : unportable+--+-- Returns the mouse selection+--+-----------------------------------------------------------------------------++module Main where++import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras+import System.Exit (exitWith, ExitCode(..))++import Data.Maybe+import Data.Char++main :: IO ()+main = do+ dpy <- openDisplay ""+ let dflt = defaultScreen dpy+ rootw <- rootWindow dpy dflt+ win <- createSimpleWindow dpy rootw 0 0 1 1 0 0 0+ p <- internAtom dpy "PRIMARY" True+ ty <- internAtom dpy "UTF8_STRING" False+ clp <- internAtom dpy "BLITZ_SEL_STRING" False+ xConvertSelection dpy p ty clp win currentTime+ allocaXEvent $ \e -> do+ nextEvent dpy e+ ev <- getEvent e+ if ev_event_type ev == selectionNotify+ then do res <- getWindowProperty8 dpy clp win+ putStrLn $ map (chr . fromIntegral) . fromMaybe [] $ res+ else do putStrLn "Failed!"+ destroyWindow dpy win+ exitWith ExitSuccess
+ src/Utils.hs view
@@ -0,0 +1,51 @@+-----------------------------------------------------------------------------+-- |+-- Module : Utils+-- Copyright : (c) Andrea Rossato+-- License : BSD3+-- +-- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>+-- Stability : unstable+-- Portability : unportable+--+-- Utilities for xmonad-utils+--+-----------------------------------------------------------------------------++module Utils where++import Control.Concurrent+import Control.Monad+import Graphics.X11.Xlib+import System.Posix.Types (Fd(..))++-- creates an invisible cursor+nullCursor :: Display -> Window -> IO Cursor+nullCursor d w = do+ let c = Color 0 0 0 0 0+ p <- createPixmap d w 1 1 1+ cursor <- createPixmapCursor d p p c c 0 0+ freePixmap d p+ return cursor++initColor :: Display -> String -> IO Pixel+initColor dpy color = do+ let colormap = defaultColormap dpy (defaultScreen dpy)+ (apros,_) <- allocNamedColor dpy colormap color+ return $ color_pixel apros++waitASecond :: Int -> IO ()+waitASecond i =+ threadDelay (i*1000000)++-- A version of maskEvent that does not block in foreign calls.+maskEvent' :: Display -> EventMask -> XEventPtr -> IO ()+maskEvent' d m p = do+ pend <- pending d+ if pend /= 0+ then maskEvent d m p+ else do+ threadWaitRead (Fd fd)+ maskEvent' d m p+ where+ fd = connectionNumber d
+ xmonad-utils.cabal view
@@ -0,0 +1,67 @@+name: xmonad-utils+version: 0.1+license: BSD3+license-file: LICENSE+author: Andrea Rossato+maintainer: <andrea.rossato@unibz.it>++stability: experimental+category: System+synopsis: A small collection of X utilities+description: A small collection of X utilities useful when+ running XMonad. It includes:+ .+ * hxsel, which returns the text currently in the X selection;+ .+ * hslock, a simple X screen lock;+ .+ * hmanage: an utility to toggle the override-redirect property of any+ window;+ .+ * and hhp, a simple utility to hide the pointer, similar+ to unclutter.+homepage: http://www.haskell.org/haskellwiki/Xmonad-utils++build-depends: base>=2.0, X11>=1.3, ghc>=6.8, unix, random>=1.0+build-type: Simple+cabal-version: >=1.4+tested-with: GHC==6.8.2++executable: hxsel+main-is: Hxsel.hs+other-modules: Heval Hhp Hmanage Hxput Hxsel Utils+hs-source-dirs: src+ghc-options: -funbox-strict-fields -Wall+ghc-prof-options: -prof -auto-all++executable: hxput+main-is: Hxput.hs+hs-source-dirs: src+ghc-options: -funbox-strict-fields -Wall+ghc-prof-options: -prof -auto-all++executable: hslock+main-is: Hslock.hs+extensions: ForeignFunctionInterface+hs-source-dirs: src+extra-libraries: crypt+ghc-options: -funbox-strict-fields -Wall+ghc-prof-options: -prof -auto-all++executable: hmanage+main-is: Hmanage.hs+hs-source-dirs: src+ghc-options: -funbox-strict-fields -Wall+ghc-prof-options: -prof -auto-all++executable: hhp+main-is: Hhp.hs+hs-source-dirs: src+ghc-options: -funbox-strict-fields -Wall+ghc-prof-options: -prof -auto-all++executable: heval+main-is: Heval.hs+hs-source-dirs: src+ghc-options: -funbox-strict-fields -Wall+ghc-prof-options: -prof -auto-all