fake identd server

-- identd: RFC1413 incompliant identd server
-- author: Ashish Shukla <gmail.com!wahjava>
-- license: GNU GPLv2 or later version at your option
-- special thanks to: consolers on #emacs
-- 1. Compile the file: abbe@chateau $ ghc --make identd.hs
-- 2. Make it setuid root: abbe@chateau $ chown 0 identd; chmod u+s identd
-- 3. Execute it: abbe@chateau $ ./identd abbe
-- happy faking ident

import System.IO (hGetContents, hClose, openFile, hPutStrLn, hGetLine)
import System.Random (randomRIO)
import IO
import Network.BSD
import Network.Socket

import System.Environment (getArgs, getProgName)

import System.Posix.User (getUserEntryForName, setUserID, UserEntry, userID)

import Control.Exception (evaluate)

wordsFile = "/usr/share/dict/words"

loadWords :: FilePath -> IO [String]
loadWords fileName = do
    handle <- openFile fileName ReadMode
    contents <- hGetContents $ handle
    let listOfWords = lines contents
    lenWords <- evaluate (length $ listOfWords)
    hClose handle
    return listOfWords

getUserName :: [String] -> IO String
getUserName words = do
    index <- randomRIO (0, length words - 1) :: IO Int
    return (words !! index)

handleSocket :: [String] -> IO (Socket, SockAddr) -> IO Bool
handleSocket words struct = do
  (socket, sockaddr) <- struct
  handle <- socketToHandle socket ReadWriteMode
  line <- hGetLine handle
  name <- getUserName words
  -- logged-in from a LISP Machine ;)
  hPutStrLn handle $ (withoutWS line) ++ " : USERID : LISPM : " ++ name
  hClose handle
  return True
  where withoutWS = filter (\x -> x `notElem` [ '\r', '\n'])

main = do
  args <- getArgs
  progName <- getProgName
  if null args
    then putStrLn $ "Usage: " ++ progName ++ " [username]"
    else do
        user <- getUserEntryForName $ args !! 0
        let uid = userID user
        rng <- getStdGenuu
        ssock <- socket AF_INET6 Stream defaultProtocol
        bindSocket ssock (SockAddrInet6 113 0 (0,0,0,0) 0)
        setUserID uid
        words <- loadWords wordsFile
        sockaddr <- getSocketName $ ssock
        listen ssock 5
        loopForever (handleSocket words . accept) ssock
        sClose ssock
  where loopForever function y = do
            retval <- function y
            if retval
              then (loopForever function y)
              else return ()

Happy faking ident…;)