Attendance tracking with pg/SaS in Haskell

gistfile1.hs

{-# LANGUAGE OverloadedStrings #-}

import System.IO
import System.IO.Error
import System.Locale
import System.Exit

import Control.Monad
import Control.Exception

import qualified Data.Text as T

import Database.PostgreSQL.Simple

import Data.Time.Clock
import Data.Time.Format
import Data.Time.LocalTime
import Data.Typeable

type ID = Int

data AttExcept = AttExcept { getExcString :: String } deriving (Show,Typeable)

instance Exception AttExcept

main = do
   conn <- connect (ConnectInfo {connectHost="localhost",connectUser="sas",connectDatabase="sas",connectPort=5432,connectPassword="wert"})
   fh <- openFile "ATT_LOG.TXT" AppendMode
   mainLoop conn fh
   close conn
   hClose fh

mainLoop :: Connection -> Handle -> IO ()
mainLoop conn fh = do {
    id <- (promptData `catch` (\e -> if isEOFError (e::IOError) then do { putStrLn "[EOF]"; return $ -1 } else do { putStrLn $ show e; promptData })); -- Exit if EOF was thrown.
    if id == -1
    then return ()
    else do
	time <- getTimeStamp; -- Not throwing
	name <- getName conn id; -- Let Exceptions propagate to the end and restart mainLoop there
	hPutStrLn fh $ (time ++ " -- " ++ (show id) ++ " " ++ name);
	hFlush fh;
	mainLoop conn fh;
    } `catch` excCatcher conn fh

promptData :: IO (ID)
promptData = do
    putStr "Bitte Nummer eingeben: "
    hFlush stdout
    nr_text <- getLine
    if nr_text == ""
    then promptData
    else return $ read nr_text

getTimeStamp :: IO String
getTimeStamp = do
    t <- getCurrentTime
    z <- getTimeZone t
    return $ formatTime defaultTimeLocale rfc822DateFormat (utcToLocalTime z t)

getName :: Connection -> ID -> IO (String)
getName conn id = do
    res <- query conn "SELECT user_name FROM users WHERE user_id = ?" (Only id)
    if length res == 0
    then do
	throw $ AttExcept "Dieser Nutzer existiert nicht in der Datenbank!"
    else do
	let (Only name) = head res
	return name

excCatcher :: Connection -> Handle -> AttExcept -> IO ()
excCatcher conn fh (AttExcept s) = do
    putStrLn $ "Ausnahme aufgetreten: " ++ s
    mainLoop conn fh