{-# 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_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 Prelude hiding (IOError)
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)
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)
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