DoRequest.hs

module DoRequest(doRequest) where
import Prelude hiding (IOError)
import DialogueIO
import ContinuationIO(stdin,stdout,stderr)
import qualified System.IO as IO
import Directory(getDirectoryContents,removeFile)
import XCall
import System
import Time(getClockTime,toCalendarTime)

doRequest :: Request -> IO Response
doRequest req =
  case req of
    ReadFile   filename          -> rdCatch (readFile filename)
    WriteFile  filename contents -> wrCatch (writeFile filename contents)
    WriteBinaryFile path contents -> wrCatch (writeBinaryFile path contents)
    AppendFile filename contents -> wrCatch (appendFile filename contents)
    ReadDirectory dir            -> rdCatch' StrList (getDirectoryContents dir)
    DeleteFile path              -> otCatch (const Success) (removeFile path)
    ReadChan channelname ->
      if channelname==stdin
      then rdCatch getContents
      else return (Failure $ ReadError $
                   "ReadChan: unknown channel "++channelname)
    AppendChan channelname contents
        | channelname==stdout -> wr IO.stdout
        | channelname==stderr -> wr IO.stderr
        | otherwise           -> return (Failure $ WriteError ("AppendChan: unknown channel "++channelname))
      where wr chan = wrCatch (IO.hPutStr chan contents>>IO.hFlush chan)
    XRequest _      -> doXCall req
    XCommand _      -> doXCall req
    GetAsyncInput   -> doSCall req
    SocketRequest _ -> doSCall req
    Select _        -> doSCall req
    ReadXdgFile {}  -> doSCall req
    WriteXdgFile {} -> doSCall req

    GetTime         -> otCatch ClockTime getClockTime
    GetLocalTime    -> otCatch CalendarTime (toCalendarTime =<< getClockTime)

    Exit n	    -> exitWith (if n==0 then ExitSuccess else ExitFailure n)
    _ -> return $ Failure $ OtherError
	   ("doRequest: unimplemented request: "++show req)

rdCatch = rdCatch' Str
rdCatch' f io = catch (fmap f $ io) (return . Failure . ReadError . show)


wrCatch io =
  catch (io >> return Success) (return . Failure . WriteError . show)

otCatch f io = catch (fmap f $ io) (return . Failure . OtherError . show)


-- Should be put elsewhere:
--instance Functor IO where map f io = io >>= (return . f)

writeBinaryFile path s = IO.withBinaryFile path IO.WriteMode (flip IO.hPutStr s)