{-# LANGUAGE CPP #-}
module DoRequest(XCallState,initXCall,doRequest,getAsyncInput) where
import Control.Applicative
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 Prelude hiding (IOError)
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)
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)
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