{-# LANGUAGE CPP #-}
module DoRequest(XCallState,initXCall,doRequest,getAsyncInput) where
import Control.Applicative
--import DialogueIO
import P_IO_data
import ContinuationIO(stdin,stdout,stderr)
import qualified System.IO as IO
import System.Environment as IO(getEnv,getProgName)
import System.Process as IO(system)
import System.Exit as IO
import qualified IOUtil as IO
import System.IO(openBinaryFile,withBinaryFile,IOMode(..),hPutStr,hGetContents)
import System.Directory
#ifdef VERSION_bytestring
import qualified Data.ByteString.Lazy as BS
#endif
#ifdef VERSION_old_time
import System.Time(getClockTime,toCalendarTime)
#endif
#ifdef VERSION_time
import Data.Time(getCurrentTime,getZonedTime)
#endif

import DoXCommand
import DoXRequest
import AsyncInput(XCallState,initXCall,getAsyncInput',doSelect,doSocketRequest)
import CmdLineEnv(argFlag)

--import System
import Prelude hiding (IOError)

--import Ap

deb :: Bool
deb = String -> Bool -> Bool
argFlag String
"dorequest" Bool
False

doRequest :: XCallState -> Request -> IO Response
doRequest =
    if Bool -> Bool
not Bool
deb
    then XCallState -> Request -> IO Response
doRequest'
    else \XCallState
state Request
req -> do
         forall {p}. Show p => p -> IO ()
eprint Request
req
	 Response
resp <- XCallState -> Request -> IO Response
doRequest' XCallState
state Request
req
	 forall {p}. Show p => p -> IO ()
eprint Response
resp
	 forall (m :: * -> *) a. Monad m => a -> m a
return Response
resp
  where
    eprint :: p -> IO ()
eprint p
x = Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
239 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ p
x

doRequest' :: XCallState -> Request -> IO Response
doRequest' :: XCallState -> Request -> IO Response
doRequest' XCallState
state Request
req =
  case Request
req of
    ReadFile   String
filename          -> IO String -> IO Response
rdCatch (String -> IO String
readFile String
filename)
    WriteFile  String
filename String
contents -> forall {a}. IO a -> IO Response
wrCatch (String -> String -> IO ()
writeFile String
filename String
contents)
    ReadBinaryFile String
filename      -> IO String -> IO Response
rdCatch (String -> IO String
readBinaryFile String
filename)
    WriteBinaryFile String
filename String
contents ->
                                    forall {a}. IO a -> IO Response
wrCatch (String -> String -> IO ()
writeBinaryFile String
filename String
contents)
#ifdef VERSION_bytestring
    ReadBinFile String
filename         -> forall {a}. (a -> Response) -> IO a -> IO Response
rdCatch' Bin -> Response
Bn (String -> IO Bin
BS.readFile String
filename)
    WriteBinFile String
filename Bin
contents ->
                                    forall {a}. IO a -> IO Response
wrCatch (String -> Bin -> IO ()
BS.writeFile String
filename Bin
contents)
    AppendBinFile String
filename Bin
contents ->
                                    forall {a}. IO a -> IO Response
wrCatch (String -> Bin -> IO ()
BS.appendFile String
filename Bin
contents)
#endif
    AppendFile String
filename String
contents -> forall {a}. IO a -> IO Response
wrCatch (String -> String -> IO ()
appendFile String
filename String
contents)
    StatusFile String
filename          -> (String -> IOError) -> IO Response -> IO Response
catchIo String -> IOError
SearchError (String -> IO Response
statusFile String
filename)
      where
        statusFile :: String -> IO Response
statusFile String
path =
	  do Bool
f <- String -> IO Bool
doesFileExist String
path
	     if Bool
f then Char -> String -> IO Response
permissions Char
'f' String
path
               else do Bool
d <- String -> IO Bool
doesDirectoryExist String
path
		       if Bool
d then Char -> String -> IO Response
permissions Char
'd' String
path
			  else forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
path
	permissions :: Char -> String -> IO Response
permissions Char
t String
path =
	  do Permissions
p <- String -> IO Permissions
getPermissions String
path
	     let r :: Char
r = if Permissions -> Bool
readable Permissions
p then Char
'r' else Char
'-'
		 w :: Char
w = if Permissions -> Bool
writable Permissions
p then Char
'w' else Char
'-'
	     forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Response
Str [Char
t,Char
r,Char
w])
    RenameFile String
from String
to         -> IO Response -> IO Response
otCatch (String -> String -> IO ()
renameFile String
from String
toforall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>IO Response
ok)
    Request
GetCurrentDirectory        -> String -> Response
Str forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getCurrentDirectory
#ifdef VERSION_old_time
    GetModificationTime String
path   -> (String -> IOError) -> IO Response -> IO Response
catchIo String -> IOError
SearchError (ClockTime -> Response
ClockTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ClockTime
IO.getModificationTime String
path)
#else
    GetModificationTime path   -> catchIo SearchError (UTCTime <$> IO.getModificationTime path)
#endif
    ReadDirectory String
dir          -> forall {a}. (a -> Response) -> IO a -> IO Response
rdCatch' [String] -> Response
StrList (String -> IO [String]
getDirectoryContents String
dir)
    DeleteFile String
filename        -> IO Response -> IO Response
otCatch (String -> IO ()
removeFile String
filenameforall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>IO Response
ok)
    CreateDirectory String
path String
mask  -> IO Response -> IO Response
otCatch (String -> IO ()
createDirectory String
pathforall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>IO Response
ok)
    ReadXdgFile XdgDirectory
xdg String
path      -> IO String -> IO Response
rdCatch forall a b. (a -> b) -> a -> b
$
                                 do String
dir <- XdgDirectory -> IO String
getAppXdgDir XdgDirectory
xdg
                                    String -> IO String
readFile (String
dirforall a. [a] -> [a] -> [a]
++String
"/"forall a. [a] -> [a] -> [a]
++String
path)
    WriteXdgFile XdgDirectory
xdg String
path String
s   -> forall {a}. IO a -> IO Response
wrCatch forall a b. (a -> b) -> a -> b
$
                                 do String
dir <- XdgDirectory -> IO String
getAppXdgDir XdgDirectory
xdg
                                    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
                                    String -> String -> IO ()
writeFile (String
dirforall a. [a] -> [a] -> [a]
++String
"/"forall a. [a] -> [a] -> [a]
++String
path) String
s
    ReadChan String
channelname ->
      if String
channelnameforall a. Eq a => a -> a -> Bool
==String
stdin
      then IO String -> IO Response
rdCatch IO String
getContents
      else IOError -> IO Response
rfail forall a b. (a -> b) -> a -> b
$ String -> IOError
ReadError forall a b. (a -> b) -> a -> b
$ String
"ReadChan: unknown channel "forall a. [a] -> [a] -> [a]
++String
channelname
    AppendChan String
channelname String
contents
        | String
channelnameforall a. Eq a => a -> a -> Bool
==String
stdout -> Handle -> IO Response
wr Handle
IO.stdout
        | String
channelnameforall a. Eq a => a -> a -> Bool
==String
stderr -> Handle -> IO Response
wr Handle
IO.stderr
        | Bool
otherwise           -> IOError -> IO Response
rfail forall a b. (a -> b) -> a -> b
$ String -> IOError
WriteError forall a b. (a -> b) -> a -> b
$ String
"AppendChan: unknown channel "forall a. [a] -> [a] -> [a]
++String
channelname
      where wr :: Handle -> IO Response
wr Handle
chan = forall {a}. IO a -> IO Response
wrCatch (Handle -> String -> IO ()
IO.hPutStr Handle
chan String
contentsforall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>Handle -> IO ()
IO.hFlush Handle
chan)
    XRequest (XDisplay, XWId, XRequest)
r      -> IO Response -> IO Response
otCatch forall a b. (a -> b) -> a -> b
$ XResponse -> Response
XResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (XDisplay, XWId, XRequest) -> IO XResponse
doXRequest (XDisplay, XWId, XRequest)
r
    XCommand (XDisplay, XWId, XCommand)
c      -> IO Response -> IO Response
otCatch forall a b. (a -> b) -> a -> b
$ ((XDisplay, XWId, XCommand) -> IO ()
doXCommand (XDisplay, XWId, XCommand)
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Response
ok)
    Request
GetAsyncInput   -> XCallState -> IO Response
getAsyncInput XCallState
state
    SocketRequest SocketRequest
r -> IO Response -> IO Response
otCatch forall a b. (a -> b) -> a -> b
$ XCallState -> SocketRequest -> IO Response
doSocketRequest XCallState
state SocketRequest
r
    Select [Descriptor]
dl       -> IO Response -> IO Response
otCatch forall a b. (a -> b) -> a -> b
$ XCallState -> [Descriptor] -> IO Response
doSelect XCallState
state [Descriptor]
dl
    Exit Int
n	    -> forall a. ExitCode -> IO a
exitWith (if Int
nforall a. Eq a => a -> a -> Bool
==Int
0 then ExitCode
ExitSuccess else Int -> ExitCode
ExitFailure Int
n)
#ifdef VERSION_old_time
    Request
GetLocalTime    -> IO Response -> IO Response
otCatch forall a b. (a -> b) -> a -> b
$ do
		         CalendarTime -> Response
CalendarTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ClockTime -> IO CalendarTime
toCalendarTime forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ClockTime
getClockTime)
			 --s <- readIO (formatCalendarTime undefined "%s" t)
			 --GHC bug(?) workaround:
                         --let s = ctSec t+60*(ctMin t+60*(ctHour t))
			 --return (Dbl (fromIntegral s))
    Request
GetTime         -> IO Response -> IO Response
otCatch forall a b. (a -> b) -> a -> b
$ ClockTime -> Response
ClockTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ClockTime
getClockTime
    ToCalendarTime ClockTime
t -> CalendarTime -> Response
CalendarTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClockTime -> IO CalendarTime
toCalendarTime ClockTime
t
#endif
    GetEnv String
var      -> (String -> IOError) -> IO Response -> IO Response
catchIo String -> IOError
SearchError (String -> Response
Str forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
getEnv String
var)
    System String
cmd      -> do ExitCode
exitcode <- String -> IO ExitCode
system String
cmd
		          case ExitCode
exitcode of
		            ExitCode
ExitSuccess -> IO Response
ok
			    ExitFailure Int
n -> IOError -> IO Response
rfail forall a b. (a -> b) -> a -> b
$ String -> IOError
OtherError forall a b. (a -> b) -> a -> b
$ String
"System: Return code="forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
n
#ifdef VERSION_time
    Request
GetCurrentTime  -> IO Response -> IO Response
otCatch forall a b. (a -> b) -> a -> b
$ UTCTime -> Response
UTCTime   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
    Request
GetZonedTime    -> IO Response -> IO Response
otCatch forall a b. (a -> b) -> a -> b
$ ZonedTime -> Response
ZonedTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTime
#endif
    Request
_ -> do Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr String
msg
            IOError -> IO Response
rfail forall a b. (a -> b) -> a -> b
$ String -> IOError
OtherError String
msg
         where msg :: String
msg = String
"doRequest: unimplemented request: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Request
req

ok :: IO Response
ok = forall (m :: * -> *) a. Monad m => a -> m a
return Response
Success
rfail :: IOError -> IO Response
rfail = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Response
Failure

getAsyncInput :: XCallState -> IO Response
getAsyncInput XCallState
state = IO Response -> IO Response
otCatch forall a b. (a -> b) -> a -> b
$ XCallState -> IO Response
getAsyncInput' XCallState
state

rdCatch :: IO String -> IO Response
rdCatch = forall {a}. (a -> Response) -> IO a -> IO Response
rdCatch' String -> Response
Str
rdCatch' :: (a -> Response) -> IO a -> IO Response
rdCatch' a -> Response
c IO a
io = (String -> IOError) -> IO Response -> IO Response
catchIo String -> IOError
ReadError (a -> Response
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
io)
wrCatch :: IO a -> IO Response
wrCatch IO a
io = (String -> IOError) -> IO Response -> IO Response
catchIo String -> IOError
WriteError (IO a
io forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Response
ok)
otCatch :: IO Response -> IO Response
otCatch = (String -> IOError) -> IO Response -> IO Response
catchIo String -> IOError
OtherError
catchIo :: (String -> IOError) -> IO Response -> IO Response
catchIo String -> IOError
e IO Response
io = forall {a}. IO a -> (IOError -> IO a) -> IO a
IO.catch IO Response
io (IOError -> IO Response
rfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)

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

--
readBinaryFile :: String -> IO String
readBinaryFile String
path = Handle -> IO String
hGetContents forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IOMode -> IO Handle
openBinaryFile String
path IOMode
ReadMode
writeBinaryFile :: String -> String -> IO ()
writeBinaryFile String
path String
s = forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path IOMode
WriteMode (forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> String -> IO ()
hPutStr String
s)

getAppXdgDir :: XdgDirectory -> IO String
getAppXdgDir XdgDirectory
xdg = XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
xdg forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
getProgName