{-# 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_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 = [Char] -> Bool -> Bool
argFlag [Char]
"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
         Request -> IO ()
forall a. Show a => a -> IO ()
eprint Request
req
	 Response
resp <- XCallState -> Request -> IO Response
doRequest' XCallState
state Request
req
	 Response -> IO ()
forall a. Show a => a -> IO ()
eprint Response
resp
	 Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
resp
  where
    eprint :: a -> IO ()
eprint a
x = Handle -> [Char] -> IO ()
IO.hPutStrLn Handle
IO.stderr ([Char] -> IO ()) -> (a -> [Char]) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
239 ([Char] -> [Char]) -> (a -> [Char]) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$ a
x

doRequest' :: XCallState -> Request -> IO Response
doRequest' :: XCallState -> Request -> IO Response
doRequest' XCallState
state Request
req =
  case Request
req of
    ReadFile   [Char]
filename          -> IO [Char] -> IO Response
rdCatch ([Char] -> IO [Char]
readFile [Char]
filename)
    WriteFile  [Char]
filename [Char]
contents -> IO () -> IO Response
forall a. IO a -> IO Response
wrCatch ([Char] -> [Char] -> IO ()
writeFile [Char]
filename [Char]
contents)
    ReadBinaryFile [Char]
filename      -> IO [Char] -> IO Response
rdCatch ([Char] -> IO [Char]
readBinaryFile [Char]
filename)
    WriteBinaryFile [Char]
filename [Char]
contents ->
                                    IO () -> IO Response
forall a. IO a -> IO Response
wrCatch ([Char] -> [Char] -> IO ()
writeBinaryFile [Char]
filename [Char]
contents)
    AppendFile [Char]
filename [Char]
contents -> IO () -> IO Response
forall a. IO a -> IO Response
wrCatch ([Char] -> [Char] -> IO ()
appendFile [Char]
filename [Char]
contents)
    StatusFile [Char]
filename          -> ([Char] -> IOError) -> IO Response -> IO Response
catchIo [Char] -> IOError
SearchError ([Char] -> IO Response
statusFile [Char]
filename)
      where
        statusFile :: [Char] -> IO Response
statusFile [Char]
path =
	  do Bool
f <- [Char] -> IO Bool
doesFileExist [Char]
path
	     if Bool
f then Char -> [Char] -> IO Response
permissions Char
'f' [Char]
path
               else do Bool
d <- [Char] -> IO Bool
doesDirectoryExist [Char]
path
		       if Bool
d then Char -> [Char] -> IO Response
permissions Char
'd' [Char]
path
			  else [Char] -> IO Response
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
path
	permissions :: Char -> [Char] -> IO Response
permissions Char
t [Char]
path =
	  do Permissions
p <- [Char] -> IO Permissions
getPermissions [Char]
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
'-'
	     Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Response
Str [Char
t,Char
r,Char
w])
    RenameFile [Char]
from [Char]
to         -> IO Response -> IO Response
otCatch ([Char] -> [Char] -> IO ()
renameFile [Char]
from [Char]
toIO () -> IO Response -> IO Response
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>IO Response
ok)
    Request
GetCurrentDirectory        -> [Char] -> Response
Str ([Char] -> Response) -> IO [Char] -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
getCurrentDirectory
#ifdef VERSION_old_time
    GetModificationTime [Char]
path   -> ([Char] -> IOError) -> IO Response -> IO Response
catchIo [Char] -> IOError
SearchError (ClockTime -> Response
ClockTime (ClockTime -> Response) -> IO ClockTime -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ClockTime
IO.getModificationTime [Char]
path)
#else
    GetModificationTime path   -> catchIo SearchError (UTCTime <$> IO.getModificationTime path)
#endif
    ReadDirectory [Char]
dir          -> ([[Char]] -> Response) -> IO [[Char]] -> IO Response
forall a. (a -> Response) -> IO a -> IO Response
rdCatch' [[Char]] -> Response
StrList ([Char] -> IO [[Char]]
getDirectoryContents [Char]
dir)
    DeleteFile [Char]
filename        -> IO Response -> IO Response
otCatch ([Char] -> IO ()
removeFile [Char]
filenameIO () -> IO Response -> IO Response
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>IO Response
ok)
    CreateDirectory [Char]
path [Char]
mask  -> IO Response -> IO Response
otCatch ([Char] -> IO ()
createDirectory [Char]
pathIO () -> IO Response -> IO Response
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>IO Response
ok)
    ReadXdgFile XdgDirectory
xdg [Char]
path      -> IO [Char] -> IO Response
rdCatch (IO [Char] -> IO Response) -> IO [Char] -> IO Response
forall a b. (a -> b) -> a -> b
$
                                 do [Char]
dir <- XdgDirectory -> IO [Char]
getAppXdgDir XdgDirectory
xdg
                                    [Char] -> IO [Char]
readFile ([Char]
dir[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"/"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
path)
    WriteXdgFile XdgDirectory
xdg [Char]
path [Char]
s   -> IO () -> IO Response
forall a. IO a -> IO Response
wrCatch (IO () -> IO Response) -> IO () -> IO Response
forall a b. (a -> b) -> a -> b
$
                                 do [Char]
dir <- XdgDirectory -> IO [Char]
getAppXdgDir XdgDirectory
xdg
                                    Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
dir
                                    [Char] -> [Char] -> IO ()
writeFile ([Char]
dir[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"/"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
path) [Char]
s
    ReadChan [Char]
channelname ->
      if [Char]
channelname[Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==[Char]
stdin
      then IO [Char] -> IO Response
rdCatch IO [Char]
getContents
      else IOError -> IO Response
rfail (IOError -> IO Response) -> IOError -> IO Response
forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
ReadError ([Char] -> IOError) -> [Char] -> IOError
forall a b. (a -> b) -> a -> b
$ [Char]
"ReadChan: unknown channel "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
channelname
    AppendChan [Char]
channelname [Char]
contents
        | [Char]
channelname[Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==[Char]
stdout -> Handle -> IO Response
wr Handle
IO.stdout
        | [Char]
channelname[Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==[Char]
stderr -> Handle -> IO Response
wr Handle
IO.stderr
        | Bool
otherwise           -> IOError -> IO Response
rfail (IOError -> IO Response) -> IOError -> IO Response
forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
WriteError ([Char] -> IOError) -> [Char] -> IOError
forall a b. (a -> b) -> a -> b
$ [Char]
"AppendChan: unknown channel "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
channelname
      where wr :: Handle -> IO Response
wr Handle
chan = IO () -> IO Response
forall a. IO a -> IO Response
wrCatch (Handle -> [Char] -> IO ()
IO.hPutStr Handle
chan [Char]
contentsIO () -> IO () -> IO ()
forall (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 (IO Response -> IO Response) -> IO Response -> IO Response
forall a b. (a -> b) -> a -> b
$ XResponse -> Response
XResponse (XResponse -> Response) -> IO XResponse -> IO Response
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 (IO Response -> IO Response) -> IO Response -> IO Response
forall a b. (a -> b) -> a -> b
$ ((XDisplay, XWId, XCommand) -> IO ()
doXCommand (XDisplay, XWId, XCommand)
c IO () -> IO Response -> IO Response
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 (IO Response -> IO Response) -> IO Response -> IO Response
forall a b. (a -> b) -> a -> b
$ XCallState -> SocketRequest -> IO Response
doSocketRequest XCallState
state SocketRequest
r
    Select [Descriptor]
dl       -> IO Response -> IO Response
otCatch (IO Response -> IO Response) -> IO Response -> IO Response
forall a b. (a -> b) -> a -> b
$ XCallState -> [Descriptor] -> IO Response
doSelect XCallState
state [Descriptor]
dl
    Exit Int
n	    -> ExitCode -> IO Response
forall a. ExitCode -> IO a
exitWith (if Int
nInt -> Int -> Bool
forall 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 (IO Response -> IO Response) -> IO Response -> IO Response
forall a b. (a -> b) -> a -> b
$ do
		         CalendarTime -> Response
CalendarTime (CalendarTime -> Response) -> IO CalendarTime -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ClockTime -> IO CalendarTime
toCalendarTime (ClockTime -> IO CalendarTime) -> IO ClockTime -> IO CalendarTime
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 (IO Response -> IO Response) -> IO Response -> IO Response
forall a b. (a -> b) -> a -> b
$ ClockTime -> Response
ClockTime (ClockTime -> Response) -> IO ClockTime -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ClockTime
getClockTime
    ToCalendarTime ClockTime
t -> CalendarTime -> Response
CalendarTime (CalendarTime -> Response) -> IO CalendarTime -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClockTime -> IO CalendarTime
toCalendarTime ClockTime
t
#endif
    GetEnv [Char]
var      -> ([Char] -> IOError) -> IO Response -> IO Response
catchIo [Char] -> IOError
SearchError ([Char] -> Response
Str ([Char] -> Response) -> IO [Char] -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
getEnv [Char]
var)
    System [Char]
cmd      -> do ExitCode
exitcode <- [Char] -> IO ExitCode
system [Char]
cmd
		          case ExitCode
exitcode of
		            ExitCode
ExitSuccess -> IO Response
ok
			    ExitFailure Int
n -> IOError -> IO Response
rfail (IOError -> IO Response) -> IOError -> IO Response
forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
OtherError ([Char] -> IOError) -> [Char] -> IOError
forall a b. (a -> b) -> a -> b
$ [Char]
"System: Return code="[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
#ifdef VERSION_time
    Request
GetCurrentTime  -> IO Response -> IO Response
otCatch (IO Response -> IO Response) -> IO Response -> IO Response
forall a b. (a -> b) -> a -> b
$ UTCTime -> Response
UTCTime   (UTCTime -> Response) -> IO UTCTime -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
    Request
GetZonedTime    -> IO Response -> IO Response
otCatch (IO Response -> IO Response) -> IO Response -> IO Response
forall a b. (a -> b) -> a -> b
$ ZonedTime -> Response
ZonedTime (ZonedTime -> Response) -> IO ZonedTime -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTime
#endif
    Request
_ -> do Handle -> [Char] -> IO ()
IO.hPutStrLn Handle
IO.stderr [Char]
msg
            IOError -> IO Response
rfail (IOError -> IO Response) -> IOError -> IO Response
forall a b. (a -> b) -> a -> b
$ [Char] -> IOError
OtherError [Char]
msg
         where msg :: [Char]
msg = [Char]
"doRequest: unimplemented request: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Request -> [Char]
forall a. Show a => a -> [Char]
show Request
req

ok :: IO Response
ok = Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
Success
rfail :: IOError -> IO Response
rfail = Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response)
-> (IOError -> Response) -> IOError -> IO Response
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 (IO Response -> IO Response) -> IO Response -> IO Response
forall a b. (a -> b) -> a -> b
$ XCallState -> IO Response
getAsyncInput' XCallState
state

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

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

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

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