[Xmonad] Re: slock issue

[Andrea Rossato]

On Tue, Aug 21, 2007 at 10:26:25AM +0200, Andrea Rossato wrote:
> As you see it is suggested to use some other alternatives till slock
> will get fixed.[1]

I wrote an alternative myself, in Haskell. Actually because I wanted
to familiarize with the FFI infrastructure (it took me far more to
understand how to pass an option to the linker then importing the C
function...;-_).

It is not slock, thought: since I didn't find a way to hide the
pointer I found a nice font for it.

To run must be set suid root (as slock). In the headers instruction on
how to build. Works only with shadow passwords.

Well, guess what? It has the same slock problem. The very same issue.
Interesting I would say!

At least now I have some code that I can understand and may be I can
even find where the problem is. I doubt though.

Andrea

PS: Dons, I know you won't like the code. But I'm sure that someone
wrote that Haskell is the best imperative language ever. And I'm
trying to provide scientific evidence of that!
-------------- next part --------------
{-# INCLUDE "shadow.h" #-}
{-# OPTIONS_GHC -optc-D_XOPEN_SOURCE #-}
{-# INCLUDE "unistd.h" #-}
{-# LINE 1 "hslock.hsc" #-}
-----------------------------------------------------------------------------
{-# LINE 2 "hslock.hsc" #-}
-- |
-- Module      :  hslock
-- Copyright   :  (C) 2007 Andrea Rossato
-- License     :  BSD3
-- 
-- Maintainer  :  andrea.rossato at 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
-----------------------------------------------------------------------------

module Main where

import Control.Monad
import Data.IORef
import Data.Maybe
import Foreign.C
import Foreign
import System.Environment

import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras

data Spwd = 
    Spwd { sp_namp :: CString
         , sp_pwdp :: CString
         }


{-# LINE 39 "hslock.hsc" #-}

{-# LINE 40 "hslock.hsc" #-}

{-# LINE 41 "hslock.hsc" #-}

foreign import ccall unsafe "shodow.h getspnam"
    getspan :: CString -> IO (Ptr Spwd)

instance Storable Spwd where
    sizeOf    _ = (36)
{-# LINE 47 "hslock.hsc" #-}
    alignment _ = alignment (undefined :: CInt)
    peek p = Spwd `fmap` (\hsc_ptr -> peekByteOff hsc_ptr 0) p
{-# LINE 49 "hslock.hsc" #-}
                  `ap`   (\hsc_ptr -> peekByteOff hsc_ptr 4) p
{-# LINE 50 "hslock.hsc" #-}
    poke p (Spwd n pw) = do
        (\hsc_ptr -> pokeByteOff hsc_ptr 0) p n
{-# LINE 52 "hslock.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 4) p pw
{-# LINE 53 "hslock.hsc" #-}

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 keyPress
  mapWindow dpy win
  sync dpy False
  ks <- grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime
  cursor <- createFontCursor dpy 88
  ps <- grabPointer dpy win False noEventMask grabModeAsync grabModeAsync win cursor currentTime
  when (ks == grabSuccess && ps == grabSuccess) $ do
          eventLoop dpy s
          ungrabKeyboard dpy currentTime
          ungrabPointer dpy currentTime
  destroyWindow dpy win
  sync dpy False

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
    | t == keyPress &&  str == "" = eventLoop d i
    | 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

initColor :: Display -> String -> IO Pixel
initColor dpy color = do
  let colormap = defaultColormap dpy (defaultScreen dpy)
  (apros,_) <- allocNamedColor dpy colormap color
  return $ color_pixel apros