    {-# 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
        , 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)

    -- | Stores information about an error encountered while creating or using a
    -- 'Socket'.
    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

    -- | 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.
          forall t. 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.
        , forall t. 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.
          forall t. 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
        , forall t. SocketOptions t -> TransportOptions t
    socketTransportOptions :: TransportOptions t
        }

    -- | Default 'SocketOptions', which uses the default Unix/TCP transport and
    -- authenticator (without support for Unix file descriptor passing).
    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 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 :: 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)

    -- | 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 :: 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 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
            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 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 :: 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 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, [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
            }

    -- | 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 :: 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

    -- | An authenticator that implements the D-Bus @EXTERNAL@ mechanism, which uses
    -- credential passing over a Unix socket, with support for Unix file descriptor passing.
    authenticatorWithUnixFds :: Authenticator SocketTransport
    authenticatorWithUnixFds :: Authenticator SocketTransport
    authenticatorWithUnixFds = UnixFdSupport -> Authenticator SocketTransport
    authExternal UnixFdSupport
    UnixFdsSupported

    -- | Implements the D-Bus @EXTERNAL@ mechanism, which uses credential
    -- passing over a Unix socket, optionally supporting Unix file descriptor passing.
    authExternal :: UnixFdSupport -> Authenticator SocketTransport
    authExternal :: UnixFdSupport -> Authenticator SocketTransport
    authExternal UnixFdSupport
    unixFdSupport = Authenticator (ZonkAny 0)
    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)

    -- | Drop /n/ items from the end of a list
    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

    -- | 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 :: 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)