{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Ejabberd api support
module Network.XMPP.Ejabberd
  ( EjabberdHost(..)
  , EUser(..)
  , VHost(..)
  , EResult(..)
  , RegisterUserReq(..)
  , localEjabberdHost
  , getRegisteredUsers
  , registerNewUser
  ) where

import GHC.Generics (Generic)
import qualified Data.Aeson as J
import qualified Data.ByteString.Lazy as BSL
import Network.HTTP.Client (RequestBody(..), Response)
import Network.HTTP.Simple
       (getResponseBody, httpLBS, parseRequest_, setRequestBody)
import Control.Exception
import Data.Text(Text)
import qualified Data.Text as Text
import Text.Printf
import Data.Char (isLower)
import Control.Applicative

data EUser =
  EUser
  { EUser -> Text
euName :: Text
  , EUser -> Text
euPassword :: Text
  } deriving (EUser -> EUser -> Bool
(EUser -> EUser -> Bool) -> (EUser -> EUser -> Bool) -> Eq EUser
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EUser -> EUser -> Bool
$c/= :: EUser -> EUser -> Bool
== :: EUser -> EUser -> Bool
$c== :: EUser -> EUser -> Bool
Eq, Int -> EUser -> ShowS
[EUser] -> ShowS
EUser -> String
(Int -> EUser -> ShowS)
-> (EUser -> String) -> ([EUser] -> ShowS) -> Show EUser
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EUser] -> ShowS
$cshowList :: [EUser] -> ShowS
show :: EUser -> String
$cshow :: EUser -> String
showsPrec :: Int -> EUser -> ShowS
$cshowsPrec :: Int -> EUser -> ShowS
Show, (forall x. EUser -> Rep EUser x)
-> (forall x. Rep EUser x -> EUser) -> Generic EUser
forall x. Rep EUser x -> EUser
forall x. EUser -> Rep EUser x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EUser x -> EUser
$cfrom :: forall x. EUser -> Rep EUser x
Generic)

newtype VHost =
  VHost { VHost -> Text
vhHost :: Text }
  deriving (VHost -> VHost -> Bool
(VHost -> VHost -> Bool) -> (VHost -> VHost -> Bool) -> Eq VHost
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VHost -> VHost -> Bool
$c/= :: VHost -> VHost -> Bool
== :: VHost -> VHost -> Bool
$c== :: VHost -> VHost -> Bool
Eq, Int -> VHost -> ShowS
[VHost] -> ShowS
VHost -> String
(Int -> VHost -> ShowS)
-> (VHost -> String) -> ([VHost] -> ShowS) -> Show VHost
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VHost] -> ShowS
$cshowList :: [VHost] -> ShowS
show :: VHost -> String
$cshow :: VHost -> String
showsPrec :: Int -> VHost -> ShowS
$cshowsPrec :: Int -> VHost -> ShowS
Show, (forall x. VHost -> Rep VHost x)
-> (forall x. Rep VHost x -> VHost) -> Generic VHost
forall x. Rep VHost x -> VHost
forall x. VHost -> Rep VHost x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VHost x -> VHost
$cfrom :: forall x. VHost -> Rep VHost x
Generic)

data EResult a
  = ESuccess a
  | EError
    { EResult a -> Text
eStatus  :: Text
    , EResult a -> Int
eCode    :: Int
    , EResult a -> Text
eMessage :: Text
    }
  deriving (EResult a -> EResult a -> Bool
(EResult a -> EResult a -> Bool)
-> (EResult a -> EResult a -> Bool) -> Eq (EResult a)
forall a. Eq a => EResult a -> EResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EResult a -> EResult a -> Bool
$c/= :: forall a. Eq a => EResult a -> EResult a -> Bool
== :: EResult a -> EResult a -> Bool
$c== :: forall a. Eq a => EResult a -> EResult a -> Bool
Eq, Int -> EResult a -> ShowS
[EResult a] -> ShowS
EResult a -> String
(Int -> EResult a -> ShowS)
-> (EResult a -> String)
-> ([EResult a] -> ShowS)
-> Show (EResult a)
forall a. Show a => Int -> EResult a -> ShowS
forall a. Show a => [EResult a] -> ShowS
forall a. Show a => EResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EResult a] -> ShowS
$cshowList :: forall a. Show a => [EResult a] -> ShowS
show :: EResult a -> String
$cshow :: forall a. Show a => EResult a -> String
showsPrec :: Int -> EResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> EResult a -> ShowS
Show)

data RegisterUserReq = RegisterUserReq
  { RegisterUserReq -> Text
rurUser :: Text
  , RegisterUserReq -> Text
rurPassword :: Text
  , RegisterUserReq -> Text
rurHost :: Text
  } deriving (RegisterUserReq -> RegisterUserReq -> Bool
(RegisterUserReq -> RegisterUserReq -> Bool)
-> (RegisterUserReq -> RegisterUserReq -> Bool)
-> Eq RegisterUserReq
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RegisterUserReq -> RegisterUserReq -> Bool
$c/= :: RegisterUserReq -> RegisterUserReq -> Bool
== :: RegisterUserReq -> RegisterUserReq -> Bool
$c== :: RegisterUserReq -> RegisterUserReq -> Bool
Eq, Int -> RegisterUserReq -> ShowS
[RegisterUserReq] -> ShowS
RegisterUserReq -> String
(Int -> RegisterUserReq -> ShowS)
-> (RegisterUserReq -> String)
-> ([RegisterUserReq] -> ShowS)
-> Show RegisterUserReq
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RegisterUserReq] -> ShowS
$cshowList :: [RegisterUserReq] -> ShowS
show :: RegisterUserReq -> String
$cshow :: RegisterUserReq -> String
showsPrec :: Int -> RegisterUserReq -> ShowS
$cshowsPrec :: Int -> RegisterUserReq -> ShowS
Show, (forall x. RegisterUserReq -> Rep RegisterUserReq x)
-> (forall x. Rep RegisterUserReq x -> RegisterUserReq)
-> Generic RegisterUserReq
forall x. Rep RegisterUserReq x -> RegisterUserReq
forall x. RegisterUserReq -> Rep RegisterUserReq x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RegisterUserReq x -> RegisterUserReq
$cfrom :: forall x. RegisterUserReq -> Rep RegisterUserReq x
Generic)

instance J.FromJSON a => J.FromJSON (EResult a) where
  parseJSON :: Value -> Parser (EResult a)
parseJSON Value
raw =
    let failed :: Parser (EResult a)
failed = ((Object -> Parser (EResult a)) -> Value -> Parser (EResult a))
-> Value -> (Object -> Parser (EResult a)) -> Parser (EResult a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser (EResult a)) -> Value -> Parser (EResult a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"EjabberdResponse") Value
raw ((Object -> Parser (EResult a)) -> Parser (EResult a))
-> (Object -> Parser (EResult a)) -> Parser (EResult a)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
          Text
status <- Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
J..: Text
"status"
          Int
code   <- Object
o Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
J..: Text
"code"
          Text
msg    <- Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
J..: Text
"message"
          EResult a -> Parser (EResult a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EResult a -> Parser (EResult a))
-> EResult a -> Parser (EResult a)
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Text -> EResult a
forall a. Text -> Int -> Text -> EResult a
EError Text
status Int
code Text
msg
        success :: Parser (EResult a)
success = a -> EResult a
forall a. a -> EResult a
ESuccess (a -> EResult a) -> Parser a -> Parser (EResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
J.parseJSON Value
raw
    in  Parser (EResult a)
success Parser (EResult a) -> Parser (EResult a) -> Parser (EResult a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (EResult a)
forall a. Parser (EResult a)
failed

instance J.ToJSON VHost where
  toJSON :: VHost -> Value
toJSON = Options -> VHost -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON Options
snakeLabel

instance J.ToJSON RegisterUserReq where
  toJSON :: RegisterUserReq -> Value
toJSON = Options -> RegisterUserReq -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON Options
snakeLabel

-- | Make sure to get the port right
--   https://docs.ejabberd.im/admin/guide/security/
--   an example is available in 'localEjabberdHost',
--   which is used for the integration tests.
newtype EjabberdHost = EjabberdHost String

snakeConstructor :: J.Options
snakeConstructor :: Options
snakeConstructor = Options
J.defaultOptions { constructorTagModifier :: ShowS
J.constructorTagModifier = Char -> ShowS
J.camelTo2 Char
'_' }

snakeLabel :: J.Options
snakeLabel :: Options
snakeLabel = Options
snakeConstructor { fieldLabelModifier :: ShowS
J.fieldLabelModifier = Char -> ShowS
J.camelTo2 Char
'_' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isLower }

localEjabberdHost :: EjabberdHost
localEjabberdHost :: EjabberdHost
localEjabberdHost = String -> EjabberdHost
EjabberdHost String
"http://localhost:5443"

toPath :: EjabberdHost -> String -> String
toPath :: EjabberdHost -> ShowS
toPath (EjabberdHost String
d) = String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"POST %s/%s" String
d

-- | https://docs.ejabberd.im/developer/ejabberd-api/admin-api/#registered-users
--
--  @since 2.0.0
getRegisteredUsers :: EjabberdHost -> VHost -> IO (EResult [Text])
getRegisteredUsers :: EjabberdHost -> VHost -> IO (EResult [Text])
getRegisteredUsers EjabberdHost
ejabberd VHost
vhost = do -- TODO: monad reader with api host and manager
  let body :: RequestBody
body = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ VHost -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode VHost
vhost
      path :: String
path = EjabberdHost -> ShowS
toPath EjabberdHost
ejabberd String
"api/registered_users"
      req :: Request
req  = RequestBody -> Request -> Request
setRequestBody RequestBody
body (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ String -> Request
parseRequest_ String
path

  Either SomeException (Response ByteString)
resp :: Either SomeException (Response BSL.ByteString) <-
    IO (Response ByteString)
-> IO (Either SomeException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
 -> IO (Either SomeException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either SomeException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS Request
req
  let eiResult :: Either SomeException (EResult [Text])
eiResult = Either String (EResult [Text]) -> EResult [Text]
forall a. Either String (EResult a) -> EResult a
returnable (Either String (EResult [Text]) -> EResult [Text])
-> (Response ByteString -> Either String (EResult [Text]))
-> Response ByteString
-> EResult [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String (EResult [Text])
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecode (ByteString -> Either String (EResult [Text]))
-> (Response ByteString -> ByteString)
-> Response ByteString
-> Either String (EResult [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody (Response ByteString -> EResult [Text])
-> Either SomeException (Response ByteString)
-> Either SomeException (EResult [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either SomeException (Response ByteString)
resp
  EResult [Text] -> IO (EResult [Text])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EResult [Text] -> IO (EResult [Text]))
-> EResult [Text] -> IO (EResult [Text])
forall a b. (a -> b) -> a -> b
$ (SomeException -> EResult [Text])
-> (EResult [Text] -> EResult [Text])
-> Either SomeException (EResult [Text])
-> EResult [Text]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Int -> Text -> EResult [Text]
forall a. Text -> Int -> Text -> EResult a
EError Text
"exception" (-Int
1) (Text -> EResult [Text])
-> (SomeException -> Text) -> SomeException -> EResult [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) EResult [Text] -> EResult [Text]
forall a. a -> a
id Either SomeException (EResult [Text])
eiResult
  where returnable :: Either String (EResult a) -> EResult a
returnable = (String -> EResult a)
-> (EResult a -> EResult a)
-> Either String (EResult a)
-> EResult a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Int -> Text -> EResult a
forall a. Text -> Int -> Text -> EResult a
EError Text
"error" (-Int
1) (Text -> EResult a) -> (String -> Text) -> String -> EResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) EResult a -> EResult a
forall a. a -> a
id

-- | https://docs.ejabberd.im/developer/ejabberd-api/admin-api/#register
--
--  @since 2.0.0
registerNewUser :: EjabberdHost -> EUser -> VHost -> IO (EResult Text)
registerNewUser :: EjabberdHost -> EUser -> VHost -> IO (EResult Text)
registerNewUser EjabberdHost
ejabberd EUser
newUser VHost
h = do
  let body :: RegisterUserReq
body = Text -> Text -> Text -> RegisterUserReq
RegisterUserReq (EUser -> Text
euName EUser
newUser) (EUser -> Text
euPassword EUser
newUser) (Text -> RegisterUserReq) -> Text -> RegisterUserReq
forall a b. (a -> b) -> a -> b
$ VHost -> Text
vhHost VHost
h
      encodedBody :: RequestBody
encodedBody = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ RegisterUserReq -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode RegisterUserReq
body
      path :: String
path        = EjabberdHost -> ShowS
toPath EjabberdHost
ejabberd String
"api/register"
      req :: Request
req         = RequestBody -> Request -> Request
setRequestBody RequestBody
encodedBody (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ String -> Request
parseRequest_ String
path

  Either SomeException (Response ByteString)
resp :: Either SomeException (Response BSL.ByteString) <-
    IO (Response ByteString)
-> IO (Either SomeException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
 -> IO (Either SomeException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either SomeException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS Request
req
  let eiResult :: Either SomeException (EResult Text)
eiResult = Either String (EResult Text) -> EResult Text
forall a. Either String (EResult a) -> EResult a
returnable (Either String (EResult Text) -> EResult Text)
-> (Response ByteString -> Either String (EResult Text))
-> Response ByteString
-> EResult Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String (EResult Text)
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecode (ByteString -> Either String (EResult Text))
-> (Response ByteString -> ByteString)
-> Response ByteString
-> Either String (EResult Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody (Response ByteString -> EResult Text)
-> Either SomeException (Response ByteString)
-> Either SomeException (EResult Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either SomeException (Response ByteString)
resp
  EResult Text -> IO (EResult Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EResult Text -> IO (EResult Text))
-> EResult Text -> IO (EResult Text)
forall a b. (a -> b) -> a -> b
$ (SomeException -> EResult Text)
-> (EResult Text -> EResult Text)
-> Either SomeException (EResult Text)
-> EResult Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Int -> Text -> EResult Text
forall a. Text -> Int -> Text -> EResult a
EError Text
"exception" (-Int
1) (Text -> EResult Text)
-> (SomeException -> Text) -> SomeException -> EResult Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) EResult Text -> EResult Text
forall a. a -> a
id Either SomeException (EResult Text)
eiResult
  where returnable :: Either String (EResult a) -> EResult a
returnable = (String -> EResult a)
-> (EResult a -> EResult a)
-> Either String (EResult a)
-> EResult a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Int -> Text -> EResult a
forall a. Text -> Int -> Text -> EResult a
EError Text
"error" (-Int
1) (Text -> EResult a) -> (String -> Text) -> String -> EResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) EResult a -> EResult a
forall a. a -> a
id