{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TypeFamilies #-}
module DBus.Socket
(
Socket
, send
, receive
, SocketError
, socketError
, socketErrorMessage
, socketErrorFatal
, socketErrorAddress
, SocketOptions
, socketAuthenticator
, socketTransportOptions
, defaultSocketOptions
, open
, openWith
, close
, SocketListener
, listen
, listenWith
, accept
, closeListener
, socketListenerAddress
, Authenticator
, authenticator
, authenticatorWithUnixFds
, authenticatorClient
, authenticatorServer
) where
import Prelude hiding (getLine)
import Control.Concurrent
import Control.Exception
import Control.Monad (mplus)
import qualified Data.ByteString
import qualified Data.ByteString.Char8 as Char8
import Data.Char (ord)
import Data.IORef
import Data.List (isPrefixOf)
import Data.Typeable (Typeable)
import qualified System.Posix.User
import Text.Printf (printf)
import DBus
import DBus.Transport
import DBus.Internal.Wire (unmarshalMessageM)
data SocketError = SocketError
{ SocketError -> [Char]
socketErrorMessage :: String
, SocketError -> Bool
socketErrorFatal :: Bool
, SocketError -> Maybe Address
socketErrorAddress :: Maybe Address
}
deriving (SocketError -> SocketError -> Bool
(SocketError -> SocketError -> Bool)
-> (SocketError -> SocketError -> Bool) -> Eq SocketError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocketError -> SocketError -> Bool
== :: SocketError -> SocketError -> Bool
$c/= :: SocketError -> SocketError -> Bool
/= :: SocketError -> SocketError -> Bool
Eq, Int -> SocketError -> ShowS
[SocketError] -> ShowS
SocketError -> [Char]
(Int -> SocketError -> ShowS)
-> (SocketError -> [Char])
-> ([SocketError] -> ShowS)
-> Show SocketError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocketError -> ShowS
showsPrec :: Int -> SocketError -> ShowS
$cshow :: SocketError -> [Char]
show :: SocketError -> [Char]
$cshowList :: [SocketError] -> ShowS
showList :: [SocketError] -> ShowS
Show, Typeable)
instance Exception SocketError
socketError :: String -> SocketError
socketError :: [Char] -> SocketError
socketError [Char]
msg = [Char] -> Bool -> Maybe Address -> SocketError
SocketError [Char]
msg Bool
True Maybe Address
forall a. Maybe a
Nothing
data SomeTransport = forall t. (Transport t) => SomeTransport t
instance Transport SomeTransport where
data TransportOptions SomeTransport = SomeTransportOptions
transportDefaultOptions :: TransportOptions SomeTransport
transportDefaultOptions = TransportOptions SomeTransport
SomeTransportOptions
transportPut :: SomeTransport -> ByteString -> IO ()
transportPut (SomeTransport t
t) = t -> ByteString -> IO ()
forall t. Transport t => t -> ByteString -> IO ()
transportPut t
t
transportPutWithFds :: SomeTransport -> ByteString -> [Fd] -> IO ()
transportPutWithFds (SomeTransport t
t) = t -> ByteString -> [Fd] -> IO ()
forall t. Transport t => t -> ByteString -> [Fd] -> IO ()
transportPutWithFds t
t
transportGet :: SomeTransport -> Int -> IO ByteString
transportGet (SomeTransport t
t) = t -> Int -> IO ByteString
forall t. Transport t => t -> Int -> IO ByteString
transportGet t
t
transportGetWithFds :: SomeTransport -> Int -> IO (ByteString, [Fd])
transportGetWithFds (SomeTransport t
t) = t -> Int -> IO (ByteString, [Fd])
forall t. Transport t => t -> Int -> IO (ByteString, [Fd])
transportGetWithFds t
t
transportClose :: SomeTransport -> IO ()
transportClose (SomeTransport t
t) = t -> IO ()
forall t. Transport t => t -> IO ()
transportClose t
t
data Socket = Socket
{ Socket -> SomeTransport
socketTransport :: SomeTransport
, Socket -> Maybe Address
socketAddress :: Maybe Address
, Socket -> IORef Serial
socketSerial :: IORef Serial
, Socket -> MVar ()
socketReadLock :: MVar ()
, Socket -> MVar ()
socketWriteLock :: MVar ()
}
data Authenticator t = Authenticator
{
forall t. Authenticator t -> t -> IO Bool
authenticatorClient :: t -> IO Bool
, forall t. Authenticator t -> t -> UUID -> IO Bool
authenticatorServer :: t -> UUID -> IO Bool
}
data SocketOptions t = SocketOptions
{
forall t. SocketOptions t -> Authenticator t
socketAuthenticator :: Authenticator t
, forall t. SocketOptions t -> TransportOptions t
socketTransportOptions :: TransportOptions t
}
defaultSocketOptions :: SocketOptions SocketTransport
defaultSocketOptions :: SocketOptions SocketTransport
defaultSocketOptions = SocketOptions
{ socketTransportOptions :: TransportOptions SocketTransport
socketTransportOptions = TransportOptions SocketTransport
forall t. Transport t => TransportOptions t
transportDefaultOptions
, socketAuthenticator :: Authenticator SocketTransport
socketAuthenticator = UnixFdSupport -> Authenticator SocketTransport
authExternal UnixFdSupport
UnixFdsNotSupported
}
open :: Address -> IO Socket
open :: Address -> IO Socket
open = SocketOptions SocketTransport -> Address -> IO Socket
forall t.
TransportOpen t =>
SocketOptions t -> Address -> IO Socket
openWith SocketOptions SocketTransport
defaultSocketOptions
openWith :: TransportOpen t => SocketOptions t -> Address -> IO Socket
openWith :: forall t.
TransportOpen t =>
SocketOptions t -> Address -> IO Socket
openWith SocketOptions t
opts Address
addr = Maybe Address -> IO Socket -> IO Socket
forall a. Maybe Address -> IO a -> IO a
toSocketError (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
addr) (IO Socket -> IO Socket) -> IO Socket -> IO Socket
forall a b. (a -> b) -> a -> b
$ IO t -> (t -> IO ()) -> (t -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(TransportOptions t -> Address -> IO t
forall t. TransportOpen t => TransportOptions t -> Address -> IO t
transportOpen (SocketOptions t -> TransportOptions t
forall t. SocketOptions t -> TransportOptions t
socketTransportOptions SocketOptions t
opts) Address
addr)
t -> IO ()
forall t. Transport t => t -> IO ()
transportClose
(\t
t -> do
authed <- Authenticator t -> t -> IO Bool
forall t. Authenticator t -> t -> IO Bool
authenticatorClient (SocketOptions t -> Authenticator t
forall t. SocketOptions t -> Authenticator t
socketAuthenticator SocketOptions t
opts) t
t
if not authed
then throwIO (socketError "Authentication failed")
{ socketErrorAddress = Just addr
}
else do
serial <- newIORef firstSerial
readLock <- newMVar ()
writeLock <- newMVar ()
return (Socket (SomeTransport t) (Just addr) serial readLock writeLock))
data SocketListener = forall t. (TransportListen t) => SocketListener (TransportListener t) (Authenticator t)
listen :: Address -> IO SocketListener
listen :: Address -> IO SocketListener
listen = SocketOptions SocketTransport -> Address -> IO SocketListener
forall t.
TransportListen t =>
SocketOptions t -> Address -> IO SocketListener
listenWith SocketOptions SocketTransport
defaultSocketOptions
listenWith :: TransportListen t => SocketOptions t -> Address -> IO SocketListener
listenWith :: forall t.
TransportListen t =>
SocketOptions t -> Address -> IO SocketListener
listenWith SocketOptions t
opts Address
addr = Maybe Address -> IO SocketListener -> IO SocketListener
forall a. Maybe Address -> IO a -> IO a
toSocketError (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
addr) (IO SocketListener -> IO SocketListener)
-> IO SocketListener -> IO SocketListener
forall a b. (a -> b) -> a -> b
$ IO (TransportListener t)
-> (TransportListener t -> IO ())
-> (TransportListener t -> IO SocketListener)
-> IO SocketListener
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(TransportOptions t -> Address -> IO (TransportListener t)
forall t.
TransportListen t =>
TransportOptions t -> Address -> IO (TransportListener t)
transportListen (SocketOptions t -> TransportOptions t
forall t. SocketOptions t -> TransportOptions t
socketTransportOptions SocketOptions t
opts) Address
addr)
TransportListener t -> IO ()
forall t. TransportListen t => TransportListener t -> IO ()
transportListenerClose
(\TransportListener t
l -> SocketListener -> IO SocketListener
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TransportListener t -> Authenticator t -> SocketListener
forall t.
TransportListen t =>
TransportListener t -> Authenticator t -> SocketListener
SocketListener TransportListener t
l (SocketOptions t -> Authenticator t
forall t. SocketOptions t -> Authenticator t
socketAuthenticator SocketOptions t
opts)))
accept :: SocketListener -> IO Socket
accept :: SocketListener -> IO Socket
accept (SocketListener TransportListener t
l Authenticator t
auth) = Maybe Address -> IO Socket -> IO Socket
forall a. Maybe Address -> IO a -> IO a
toSocketError Maybe Address
forall a. Maybe a
Nothing (IO Socket -> IO Socket) -> IO Socket -> IO Socket
forall a b. (a -> b) -> a -> b
$ IO t -> (t -> IO ()) -> (t -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(TransportListener t -> IO t
forall t. TransportListen t => TransportListener t -> IO t
transportAccept TransportListener t
l)
t -> IO ()
forall t. Transport t => t -> IO ()
transportClose
(\t
t -> do
let uuid :: UUID
uuid = TransportListener t -> UUID
forall t. TransportListen t => TransportListener t -> UUID
transportListenerUUID TransportListener t
l
authed <- Authenticator t -> t -> UUID -> IO Bool
forall t. Authenticator t -> t -> UUID -> IO Bool
authenticatorServer Authenticator t
auth t
t UUID
uuid
if not authed
then throwIO (socketError "Authentication failed")
else do
serial <- newIORef firstSerial
readLock <- newMVar ()
writeLock <- newMVar ()
return (Socket (SomeTransport t) Nothing serial readLock writeLock))
close :: Socket -> IO ()
close :: Socket -> IO ()
close = SomeTransport -> IO ()
forall t. Transport t => t -> IO ()
transportClose (SomeTransport -> IO ())
-> (Socket -> SomeTransport) -> Socket -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> SomeTransport
socketTransport
closeListener :: SocketListener -> IO ()
closeListener :: SocketListener -> IO ()
closeListener (SocketListener TransportListener t
l Authenticator t
_) = TransportListener t -> IO ()
forall t. TransportListen t => TransportListener t -> IO ()
transportListenerClose TransportListener t
l
socketListenerAddress :: SocketListener -> Address
socketListenerAddress :: SocketListener -> Address
socketListenerAddress (SocketListener TransportListener t
l Authenticator t
_) = TransportListener t -> Address
forall t. TransportListen t => TransportListener t -> Address
transportListenerAddress TransportListener t
l
send :: Message msg => Socket -> msg -> (Serial -> IO a) -> IO a
send :: forall msg a.
Message msg =>
Socket -> msg -> (Serial -> IO a) -> IO a
send Socket
sock msg
msg Serial -> IO a
io = Maybe Address -> IO a -> IO a
forall a. Maybe Address -> IO a -> IO a
toSocketError (Socket -> Maybe Address
socketAddress Socket
sock) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
serial <- Socket -> IO Serial
nextSocketSerial Socket
sock
case marshalWithFds LittleEndian serial msg of
Right (ByteString
bytes, [Fd]
fds) -> do
let t :: SomeTransport
t = Socket -> SomeTransport
socketTransport Socket
sock
a <- Serial -> IO a
io Serial
serial
withMVar (socketWriteLock sock) (\()
_ -> SomeTransport -> ByteString -> [Fd] -> IO ()
forall t. Transport t => t -> ByteString -> [Fd] -> IO ()
transportPutWithFds SomeTransport
t ByteString
bytes [Fd]
fds)
return a
Left MarshalError
err -> SocketError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([Char] -> SocketError
socketError ([Char]
"Message cannot be sent: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ MarshalError -> [Char]
forall a. Show a => a -> [Char]
show MarshalError
err))
{ socketErrorFatal = False
}
nextSocketSerial :: Socket -> IO Serial
nextSocketSerial :: Socket -> IO Serial
nextSocketSerial Socket
sock = IORef Serial -> (Serial -> (Serial, Serial)) -> IO Serial
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (Socket -> IORef Serial
socketSerial Socket
sock) (\Serial
x -> (Serial -> Serial
nextSerial Serial
x, Serial
x))
receive :: Socket -> IO ReceivedMessage
receive :: Socket -> IO ReceivedMessage
receive Socket
sock = Maybe Address -> IO ReceivedMessage -> IO ReceivedMessage
forall a. Maybe Address -> IO a -> IO a
toSocketError (Socket -> Maybe Address
socketAddress Socket
sock) (IO ReceivedMessage -> IO ReceivedMessage)
-> IO ReceivedMessage -> IO ReceivedMessage
forall a b. (a -> b) -> a -> b
$ do
let t :: SomeTransport
t = Socket -> SomeTransport
socketTransport Socket
sock
let get :: Int -> IO (ByteString, [Fd])
get Int
n = if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then (ByteString, [Fd]) -> IO (ByteString, [Fd])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
Data.ByteString.empty, [])
else SomeTransport -> Int -> IO (ByteString, [Fd])
forall t. Transport t => t -> Int -> IO (ByteString, [Fd])
transportGetWithFds SomeTransport
t Int
n
received <- MVar ()
-> (() -> IO (Either UnmarshalError ReceivedMessage))
-> IO (Either UnmarshalError ReceivedMessage)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Socket -> MVar ()
socketReadLock Socket
sock) (\()
_ -> (Int -> IO (ByteString, [Fd]))
-> IO (Either UnmarshalError ReceivedMessage)
forall (m :: * -> *).
Monad m =>
(Int -> m (ByteString, [Fd]))
-> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM Int -> IO (ByteString, [Fd])
get)
case received of
Left UnmarshalError
err -> SocketError -> IO ReceivedMessage
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([Char] -> SocketError
socketError ([Char]
"Error reading message from socket: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ UnmarshalError -> [Char]
forall a. Show a => a -> [Char]
show UnmarshalError
err))
Right ReceivedMessage
msg -> ReceivedMessage -> IO ReceivedMessage
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ReceivedMessage
msg
toSocketError :: Maybe Address -> IO a -> IO a
toSocketError :: forall a. Maybe Address -> IO a -> IO a
toSocketError Maybe Address
addr IO a
io = IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
catches IO a
io [Handler a]
handlers where
handlers :: [Handler a]
handlers =
[ (TransportError -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler TransportError -> IO a
catchTransportError
, (SocketError -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler SocketError -> IO a
updateSocketError
, (IOException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler IOException -> IO a
catchIOException
]
catchTransportError :: TransportError -> IO a
catchTransportError TransportError
err = SocketError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([Char] -> SocketError
socketError (TransportError -> [Char]
transportErrorMessage TransportError
err))
{ socketErrorAddress = addr
}
updateSocketError :: SocketError -> IO a
updateSocketError SocketError
err = SocketError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SocketError
err
{ socketErrorAddress = mplus (socketErrorAddress err) addr
}
catchIOException :: IOException -> IO a
catchIOException IOException
exc = SocketError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([Char] -> SocketError
socketError (IOException -> [Char]
forall a. Show a => a -> [Char]
show (IOException
exc :: IOException)))
{ socketErrorAddress = addr
}
authenticator :: Authenticator t
authenticator :: forall t. Authenticator t
authenticator = (t -> IO Bool) -> (t -> UUID -> IO Bool) -> Authenticator t
forall t.
(t -> IO Bool) -> (t -> UUID -> IO Bool) -> Authenticator t
Authenticator (\t
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (\t
_ UUID
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
data UnixFdSupport = UnixFdsSupported | UnixFdsNotSupported
authenticatorWithUnixFds :: Authenticator SocketTransport
authenticatorWithUnixFds :: Authenticator SocketTransport
authenticatorWithUnixFds = UnixFdSupport -> Authenticator SocketTransport
authExternal UnixFdSupport
UnixFdsSupported
authExternal :: UnixFdSupport -> Authenticator SocketTransport
authExternal :: UnixFdSupport -> Authenticator SocketTransport
authExternal UnixFdSupport
unixFdSupport = Authenticator Any
forall t. Authenticator t
authenticator
{ authenticatorClient = clientAuthExternal unixFdSupport
, authenticatorServer = serverAuthExternal unixFdSupport
}
clientAuthExternal :: UnixFdSupport -> SocketTransport -> IO Bool
clientAuthExternal :: UnixFdSupport -> SocketTransport -> IO Bool
clientAuthExternal UnixFdSupport
unixFdSupport SocketTransport
t = do
SocketTransport -> ByteString -> IO ()
forall t. Transport t => t -> ByteString -> IO ()
transportPut SocketTransport
t ([Word8] -> ByteString
Data.ByteString.pack [Word8
0])
uid <- IO UserID
System.Posix.User.getRealUserID
let token = (Char -> [Char]) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%02X" (Int -> [Char]) -> (Char -> Int) -> Char -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) (UserID -> [Char]
forall a. Show a => a -> [Char]
show UserID
uid)
transportPutLine t ("AUTH EXTERNAL " ++ token)
resp <- transportGetLine t
case splitPrefix "OK " resp of
Just [Char]
_ -> do
ok <- do
case UnixFdSupport
unixFdSupport of
UnixFdSupport
UnixFdsSupported -> do
SocketTransport -> [Char] -> IO ()
forall t. Transport t => t -> [Char] -> IO ()
transportPutLine SocketTransport
t [Char]
"NEGOTIATE_UNIX_FD"
respFd <- SocketTransport -> IO [Char]
forall t. Transport t => t -> IO [Char]
transportGetLine SocketTransport
t
return (respFd == "AGREE_UNIX_FD")
UnixFdSupport
UnixFdsNotSupported -> do
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
if ok then do
transportPutLine t "BEGIN"
return True
else
return False
Maybe [Char]
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
serverAuthExternal :: UnixFdSupport -> SocketTransport -> UUID -> IO Bool
serverAuthExternal :: UnixFdSupport -> SocketTransport -> UUID -> IO Bool
serverAuthExternal UnixFdSupport
unixFdSupport SocketTransport
t UUID
uuid = do
let negotiateFdsAndBegin :: IO ()
negotiateFdsAndBegin = do
line <- SocketTransport -> IO [Char]
forall t. Transport t => t -> IO [Char]
transportGetLine SocketTransport
t
case line of
[Char]
"NEGOTIATE_UNIX_FD" -> do
let msg :: [Char]
msg = case UnixFdSupport
unixFdSupport of
UnixFdSupport
UnixFdsSupported ->
[Char]
"AGREE_UNIX_FD"
UnixFdSupport
UnixFdsNotSupported ->
[Char]
"ERROR Unix File Descriptor support is not configured."
SocketTransport -> [Char] -> IO ()
forall t. Transport t => t -> [Char] -> IO ()
transportPutLine SocketTransport
t [Char]
msg
IO ()
negotiateFdsAndBegin
[Char]
"BEGIN" ->
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Char]
_ ->
IO ()
negotiateFdsAndBegin
let checkToken :: [Char] -> IO Bool
checkToken [Char]
token = do
(_, uid, _) <- SocketTransport -> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt)
socketTransportCredentials SocketTransport
t
let wantToken = (Char -> [Char]) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%02X" (Int -> [Char]) -> (Char -> Int) -> Char -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) ([Char] -> (CUInt -> [Char]) -> Maybe CUInt -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"XXX" CUInt -> [Char]
forall a. Show a => a -> [Char]
show Maybe CUInt
uid)
if token == wantToken
then do
transportPutLine t ("OK " ++ formatUUID uuid)
negotiateFdsAndBegin
return True
else return False
c <- SocketTransport -> Int -> IO ByteString
forall t. Transport t => t -> Int -> IO ByteString
transportGet SocketTransport
t Int
1
if c /= Char8.pack "\x00"
then return False
else do
line <- transportGetLine t
case splitPrefix "AUTH EXTERNAL " line of
Just [Char]
token -> [Char] -> IO Bool
checkToken [Char]
token
Maybe [Char]
Nothing -> if [Char]
line [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"AUTH EXTERNAL"
then do
dataLine <- SocketTransport -> IO [Char]
forall t. Transport t => t -> IO [Char]
transportGetLine SocketTransport
t
case splitPrefix "DATA " dataLine of
Just [Char]
token -> [Char] -> IO Bool
checkToken [Char]
token
Maybe [Char]
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
transportPutLine :: Transport t => t -> String -> IO ()
transportPutLine :: forall t. Transport t => t -> [Char] -> IO ()
transportPutLine t
t [Char]
line = t -> ByteString -> IO ()
forall t. Transport t => t -> ByteString -> IO ()
transportPut t
t ([Char] -> ByteString
Char8.pack ([Char]
line [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\r\n"))
transportGetLine :: Transport t => t -> IO String
transportGetLine :: forall t. Transport t => t -> IO [Char]
transportGetLine t
t = do
let getchr :: IO Char
getchr = ByteString -> Char
Char8.head (ByteString -> Char) -> IO ByteString -> IO Char
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` t -> Int -> IO ByteString
forall t. Transport t => t -> Int -> IO ByteString
transportGet t
t Int
1
raw <- [Char] -> IO Char -> IO [Char]
forall (m :: * -> *) a. (Monad m, Eq a) => [a] -> m a -> m [a]
readUntil [Char]
"\r\n" IO Char
getchr
return (dropEnd 2 raw)
dropEnd :: Int -> [a] -> [a]
dropEnd :: forall a. Int -> [a] -> [a]
dropEnd Int
n [a]
xs = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) [a]
xs
splitPrefix :: String -> String -> Maybe String
splitPrefix :: [Char] -> [Char] -> Maybe [Char]
splitPrefix [Char]
prefix [Char]
str = if [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
prefix [Char]
str
then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Int -> ShowS
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
prefix) [Char]
str)
else Maybe [Char]
forall a. Maybe a
Nothing
readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a]
readUntil :: forall (m :: * -> *) a. (Monad m, Eq a) => [a] -> m a -> m [a]
readUntil [a]
guard m a
getx = [a] -> m [a]
readUntil' [] where
guard' :: [a]
guard' = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
guard
step :: [a] -> m [a]
step [a]
xs | [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
guard' [a]
xs = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs)
| Bool
otherwise = [a] -> m [a]
readUntil' [a]
xs
readUntil' :: [a] -> m [a]
readUntil' [a]
xs = do
x <- m a
getx
step (x:xs)