{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TypeFamilies #-}

-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

-- | D-Bus sockets are used for communication between two peers. In this model,
-- there is no \"bus\" or \"client\", simply two endpoints sending messages.
--
-- Most users will want to use the "DBus.Client" module instead.
module DBus.Socket
    (

    -- * Sockets
      Socket
    , send
    , receive

    -- * Socket errors
    , SocketError
    , socketError
    , socketErrorMessage
    , socketErrorFatal
    , socketErrorAddress

    -- * Socket options
    , SocketOptions
    , socketAuthenticator
    , socketTransportOptions
    , defaultSocketOptions

    -- * Opening and closing sockets
    , open
    , openWith
    , close

    -- * Listening for connections
    , SocketListener
    , listen
    , listenWith
    , accept
    , closeListener
    , socketListenerAddress

    -- * Authentication
    , Authenticator
    , authenticator
    , 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)

-- | Stores information about an error encountered while creating or using a
-- 'Socket'.
data SocketError = SocketError
    { SocketError -> String
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
/= :: SocketError -> SocketError -> Bool
$c/= :: SocketError -> SocketError -> Bool
== :: SocketError -> SocketError -> Bool
$c== :: SocketError -> SocketError -> Bool
Eq, Int -> SocketError -> ShowS
[SocketError] -> ShowS
SocketError -> String
(Int -> SocketError -> ShowS)
-> (SocketError -> String)
-> ([SocketError] -> ShowS)
-> Show SocketError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SocketError] -> ShowS
$cshowList :: [SocketError] -> ShowS
show :: SocketError -> String
$cshow :: SocketError -> String
showsPrec :: Int -> SocketError -> ShowS
$cshowsPrec :: Int -> SocketError -> ShowS
Show, Typeable)

instance Exception SocketError

socketError :: String -> SocketError
socketError :: String -> SocketError
socketError String
msg = String -> Bool -> Maybe Address -> SocketError
SocketError String
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
    transportGet :: SomeTransport -> Int -> IO ByteString
transportGet (SomeTransport t
t) = t -> Int -> IO ByteString
forall t. Transport t => t -> Int -> IO ByteString
transportGet t
t
    transportClose :: SomeTransport -> IO ()
transportClose (SomeTransport t
t) = t -> IO ()
forall t. Transport t => t -> IO ()
transportClose t
t

-- | An open socket to another process. Messages can be sent to the remote
-- peer using 'send', or received using 'receive'.
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 ()
    }

-- | An Authenticator defines how the local peer (client) authenticates
-- itself to the remote peer (server).
data Authenticator t = Authenticator
    {
    -- | Defines the client-side half of an authenticator.
      Authenticator t -> t -> IO Bool
authenticatorClient :: t -> IO Bool

    -- | Defines the server-side half of an authenticator. The UUID is
    -- allocated by the socket listener.
    , Authenticator t -> t -> UUID -> IO Bool
authenticatorServer :: t -> UUID -> IO Bool
    }

-- | Used with 'openWith' and 'listenWith' to provide custom authenticators or
-- transport options.
data SocketOptions t = SocketOptions
    {
    -- | Used to perform authentication with the remote peer. After a
    -- transport has been opened, it will be passed to the authenticator.
    -- If the authenticator returns true, then the socket was
    -- authenticated.
      SocketOptions t -> Authenticator t
socketAuthenticator :: Authenticator t

    -- | Options for the underlying transport, to be used by custom transports
    -- for controlling how to connect to the remote peer.
    --
    -- See "DBus.Transport" for details on defining custom transports
    , SocketOptions t -> TransportOptions t
socketTransportOptions :: TransportOptions t
    }

-- | Default 'SocketOptions', which uses the default Unix/TCP transport and
-- authenticator.
defaultSocketOptions :: SocketOptions SocketTransport
defaultSocketOptions :: SocketOptions SocketTransport
defaultSocketOptions = SocketOptions :: forall t. Authenticator t -> TransportOptions t -> SocketOptions t
SocketOptions
    { socketTransportOptions :: TransportOptions SocketTransport
socketTransportOptions = TransportOptions SocketTransport
forall t. Transport t => TransportOptions t
transportDefaultOptions
    , socketAuthenticator :: Authenticator SocketTransport
socketAuthenticator = Authenticator SocketTransport
authExternal
    }

-- | Open a socket to a remote peer listening at the given address.
--
-- @
--open = 'openWith' 'defaultSocketOptions'
-- @
--
-- Throws 'SocketError' on failure.
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

-- | Open a socket to a remote peer listening at the given address.
--
-- Most users should use 'open'. This function is for users who need to define
-- custom authenticators or transports.
--
-- Throws 'SocketError' on failure.
openWith :: TransportOpen t => SocketOptions t -> Address -> IO Socket
openWith :: 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
        Bool
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 Bool -> Bool
not Bool
authed
            then SocketError -> IO Socket
forall e a. Exception e => e -> IO a
throwIO (String -> SocketError
socketError String
"Authentication failed")
                { socketErrorAddress :: Maybe Address
socketErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
addr
                }
            else do
                IORef Serial
serial <- Serial -> IO (IORef Serial)
forall a. a -> IO (IORef a)
newIORef Serial
firstSerial
                MVar ()
readLock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
                MVar ()
writeLock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
                Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeTransport
-> Maybe Address -> IORef Serial -> MVar () -> MVar () -> Socket
Socket (t -> SomeTransport
forall t. Transport t => t -> SomeTransport
SomeTransport t
t) (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
addr) IORef Serial
serial MVar ()
readLock MVar ()
writeLock))

data SocketListener = forall t. (TransportListen t) => SocketListener (TransportListener t) (Authenticator t)

-- | Begin listening at the given address.
--
-- Use 'accept' to create sockets from incoming connections.
--
-- Use 'closeListener' to stop listening, and to free underlying transport
-- resources such as file descriptors.
--
-- Throws 'SocketError' on failure.
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

-- | Begin listening at the given address.
--
-- Use 'accept' to create sockets from incoming connections.
--
-- Use 'closeListener' to stop listening, and to free underlying transport
-- resources such as file descriptors.
--
-- This function is for users who need to define custom authenticators
-- or transports.
--
-- Throws 'SocketError' on failure.
listenWith :: TransportListen t => SocketOptions t -> Address -> IO SocketListener
listenWith :: 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 (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 a new connection from a socket listener.
--
-- Throws 'SocketError' on failure.
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
        Bool
authed <- Authenticator t -> t -> UUID -> IO Bool
forall t. Authenticator t -> t -> UUID -> IO Bool
authenticatorServer Authenticator t
auth t
t UUID
uuid
        if Bool -> Bool
not Bool
authed
            then SocketError -> IO Socket
forall e a. Exception e => e -> IO a
throwIO (String -> SocketError
socketError String
"Authentication failed")
            else do
                IORef Serial
serial <- Serial -> IO (IORef Serial)
forall a. a -> IO (IORef a)
newIORef Serial
firstSerial
                MVar ()
readLock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
                MVar ()
writeLock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
                Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeTransport
-> Maybe Address -> IORef Serial -> MVar () -> MVar () -> Socket
Socket (t -> SomeTransport
forall t. Transport t => t -> SomeTransport
SomeTransport t
t) Maybe Address
forall a. Maybe a
Nothing IORef Serial
serial MVar ()
readLock MVar ()
writeLock))

-- | Close an open 'Socket'. Once closed, the socket is no longer valid and
-- must not be used.
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

-- | Close an open 'SocketListener'. Once closed, the listener is no longer
-- valid and must not be used.
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

-- | Get the address to use to connect to a listener.
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 a single message, with a generated 'Serial'. The second parameter
-- exists to prevent race conditions when registering a reply handler; it
-- receives the serial the message /will/ be sent with, before it's
-- actually sent.
--
-- Sockets are thread-safe. Only one message may be sent at a time; if
-- multiple threads attempt to send messages concurrently, one will block
-- until after the other has finished.
--
-- Throws 'SocketError' on failure.
send :: Message msg => Socket -> msg -> (Serial -> IO a) -> IO a
send :: 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
serial <- Socket -> IO Serial
nextSocketSerial Socket
sock
    case Endianness -> Serial -> msg -> Either MarshalError ByteString
forall msg.
Message msg =>
Endianness -> Serial -> msg -> Either MarshalError ByteString
marshal Endianness
LittleEndian Serial
serial msg
msg of
        Right ByteString
bytes -> do
            let t :: SomeTransport
t = Socket -> SomeTransport
socketTransport Socket
sock
            a
a <- Serial -> IO a
io Serial
serial
            MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Socket -> MVar ()
socketWriteLock Socket
sock) (\()
_ -> SomeTransport -> ByteString -> IO ()
forall t. Transport t => t -> ByteString -> IO ()
transportPut SomeTransport
t ByteString
bytes)
            a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        Left MarshalError
err -> SocketError -> IO a
forall e a. Exception e => e -> IO a
throwIO (String -> SocketError
socketError (String
"Message cannot be sent: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MarshalError -> String
forall a. Show a => a -> String
show MarshalError
err))
            { socketErrorFatal :: Bool
socketErrorFatal = Bool
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 the next message from the socket , blocking until one is available.
--
-- Sockets are thread-safe. Only one message may be received at a time; if
-- multiple threads attempt to receive messages concurrently, one will block
-- until after the other has finished.
--
-- Throws 'SocketError' on failure.
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
    -- TODO: after reading the length, read all bytes from the
    --       handle, then return a closure to perform the parse
    --       outside of the lock.
    let t :: SomeTransport
t = Socket -> SomeTransport
socketTransport Socket
sock
    let get :: Int -> IO ByteString
get Int
n = if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
            then ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
Data.ByteString.empty
            else SomeTransport -> Int -> IO ByteString
forall t. Transport t => t -> Int -> IO ByteString
transportGet SomeTransport
t Int
n
    Either UnmarshalError ReceivedMessage
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)
-> IO (Either UnmarshalError ReceivedMessage)
forall (m :: * -> *).
Monad m =>
(Int -> m ByteString) -> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM Int -> IO ByteString
get)
    case Either UnmarshalError ReceivedMessage
received of
        Left UnmarshalError
err -> SocketError -> IO ReceivedMessage
forall e a. Exception e => e -> IO a
throwIO (String -> SocketError
socketError (String
"Error reading message from socket: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnmarshalError -> String
forall a. Show a => a -> String
show UnmarshalError
err))
        Right ReceivedMessage
msg -> ReceivedMessage -> IO ReceivedMessage
forall (m :: * -> *) a. Monad m => a -> m a
return ReceivedMessage
msg

toSocketError :: Maybe Address -> IO a -> IO a
toSocketError :: 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. Exception e => e -> IO a
throwIO (String -> SocketError
socketError (TransportError -> String
transportErrorMessage TransportError
err))
        { socketErrorAddress :: Maybe Address
socketErrorAddress = Maybe Address
addr
        }
    updateSocketError :: SocketError -> IO a
updateSocketError SocketError
err = SocketError -> IO a
forall e a. Exception e => e -> IO a
throwIO SocketError
err
        { socketErrorAddress :: Maybe Address
socketErrorAddress = Maybe Address -> Maybe Address -> Maybe Address
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus (SocketError -> Maybe Address
socketErrorAddress SocketError
err) Maybe Address
addr
        }
    catchIOException :: IOException -> IO a
catchIOException IOException
exc = SocketError -> IO a
forall e a. Exception e => e -> IO a
throwIO (String -> SocketError
socketError (IOException -> String
forall a. Show a => a -> String
show (IOException
exc :: IOException)))
        { socketErrorAddress :: Maybe Address
socketErrorAddress = Maybe Address
addr
        }

-- | An empty authenticator. Use 'authenticatorClient' or 'authenticatorServer'
-- to control how the authentication is performed.
--
-- @
--myAuthenticator :: Authenticator MyTransport
--myAuthenticator = authenticator
--    { 'authenticatorClient' = clientMyAuth
--    , 'authenticatorServer' = serverMyAuth
--    }
--
--clientMyAuth :: MyTransport -> IO Bool
--serverMyAuth :: MyTransport -> String -> IO Bool
-- @
authenticator :: Authenticator t
authenticator :: 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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (\t
_ UUID
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

-- | Implements the D-Bus @EXTERNAL@ mechanism, which uses credential
-- passing over a Unix socket.
authExternal :: Authenticator SocketTransport
authExternal :: Authenticator SocketTransport
authExternal = Authenticator Any
forall t. Authenticator t
authenticator
    { authenticatorClient :: SocketTransport -> IO Bool
authenticatorClient = SocketTransport -> IO Bool
clientAuthExternal
    , authenticatorServer :: SocketTransport -> UUID -> IO Bool
authenticatorServer = SocketTransport -> UUID -> IO Bool
serverAuthExternal
    }

clientAuthExternal :: SocketTransport -> IO Bool
clientAuthExternal :: SocketTransport -> IO Bool
clientAuthExternal SocketTransport
t = do
    SocketTransport -> ByteString -> IO ()
forall t. Transport t => t -> ByteString -> IO ()
transportPut SocketTransport
t ([Word8] -> ByteString
Data.ByteString.pack [Word8
0])
    UserID
uid <- IO UserID
System.Posix.User.getRealUserID
    let token :: String
token = (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%02X" (Int -> String) -> (Char -> Int) -> Char -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) (UserID -> String
forall a. Show a => a -> String
show UserID
uid)
    SocketTransport -> String -> IO ()
forall t. Transport t => t -> String -> IO ()
transportPutLine SocketTransport
t (String
"AUTH EXTERNAL " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
token)
    String
resp <- SocketTransport -> IO String
forall t. Transport t => t -> IO String
transportGetLine SocketTransport
t
    case String -> String -> Maybe String
splitPrefix String
"OK " String
resp of
        Just String
_ -> do
            SocketTransport -> String -> IO ()
forall t. Transport t => t -> String -> IO ()
transportPutLine SocketTransport
t String
"BEGIN"
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Maybe String
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

serverAuthExternal :: SocketTransport -> UUID -> IO Bool
serverAuthExternal :: SocketTransport -> UUID -> IO Bool
serverAuthExternal SocketTransport
t UUID
uuid = do
    let waitForBegin :: IO ()
waitForBegin = do
            String
resp <- SocketTransport -> IO String
forall t. Transport t => t -> IO String
transportGetLine SocketTransport
t
            if String
resp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BEGIN"
                then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                else IO ()
waitForBegin

    let checkToken :: String -> IO Bool
checkToken String
token = do
            (Maybe CUInt
_, Maybe CUInt
uid, Maybe CUInt
_) <- SocketTransport -> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt)
socketTransportCredentials SocketTransport
t
            let wantToken :: String
wantToken = (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%02X" (Int -> String) -> (Char -> Int) -> Char -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) (String -> (CUInt -> String) -> Maybe CUInt -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"XXX" CUInt -> String
forall a. Show a => a -> String
show Maybe CUInt
uid)
            if String
token String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
wantToken
                then do
                    SocketTransport -> String -> IO ()
forall t. Transport t => t -> String -> IO ()
transportPutLine SocketTransport
t (String
"OK " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UUID -> String
formatUUID UUID
uuid)
                    IO ()
waitForBegin
                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    ByteString
c <- SocketTransport -> Int -> IO ByteString
forall t. Transport t => t -> Int -> IO ByteString
transportGet SocketTransport
t Int
1
    if ByteString
c ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> ByteString
Char8.pack String
"\x00"
        then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        else do
            String
line <- SocketTransport -> IO String
forall t. Transport t => t -> IO String
transportGetLine SocketTransport
t
            case String -> String -> Maybe String
splitPrefix String
"AUTH EXTERNAL " String
line of
                Just String
token -> String -> IO Bool
checkToken String
token
                Maybe String
Nothing -> if String
line String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"AUTH EXTERNAL"
                    then do
                        String
dataLine <- SocketTransport -> IO String
forall t. Transport t => t -> IO String
transportGetLine SocketTransport
t
                        case String -> String -> Maybe String
splitPrefix String
"DATA " String
dataLine of
                            Just String
token -> String -> IO Bool
checkToken String
token
                            Maybe String
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                    else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

transportPutLine :: Transport t => t -> String -> IO ()
transportPutLine :: t -> String -> IO ()
transportPutLine t
t String
line = t -> ByteString -> IO ()
forall t. Transport t => t -> ByteString -> IO ()
transportPut t
t (String -> ByteString
Char8.pack (String
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\r\n"))

transportGetLine :: Transport t => t -> IO String
transportGetLine :: t -> IO String
transportGetLine t
t = do
    let getchr :: IO Char
getchr = ByteString -> Char
Char8.head (ByteString -> Char) -> IO ByteString -> IO Char
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
    String
raw <- String -> IO Char -> IO String
forall (m :: * -> *) a. (Monad m, Eq a) => [a] -> m a -> m [a]
readUntil String
"\r\n" IO Char
getchr
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ShowS
forall a. Int -> [a] -> [a]
dropEnd Int
2 String
raw)

-- | Drop /n/ items from the end of a list
dropEnd :: Int -> [a] -> [a]
dropEnd :: Int -> [a] -> [a]
dropEnd Int
n [a]
xs = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([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 :: String -> String -> Maybe String
splitPrefix String
prefix String
str = if String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
prefix String
str
    then String -> Maybe String
forall a. a -> Maybe a
Just (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix) String
str)
    else Maybe String
forall a. Maybe a
Nothing

-- | Read values from a monad until a guard value is read; return all
-- values, including the guard.
readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a]
readUntil :: [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 (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
        a
x <- m a
getx
        [a] -> m [a]
step (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)