{-# Language DataKinds #-}
{-# Language OverloadedStrings #-}
{-# Language RecordWildCards #-}
{-# Language ScopedTypeVariables #-}

module Data.TTN.Client (
    ttnClient
  , ttnClientConf
  , withTTN
  , Conf(..)
  , envConfCfg
  , parseConfCfg
  ) where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception (Handler (..), IOException, catches)
import Control.Monad
import Data.Text (Text)

import System.Exit (exitFailure)
import System.IO (hPutStrLn, stderr)

import Data.TTN
import Network.MQTT.Client
import qualified Network.URI

import qualified Data.Text
import qualified Data.Text.IO
import qualified Data.ByteString.Lazy

import Data.Ini.Config
import System.Directory
import System.FilePath.Posix
import qualified System.Environment

data Conf = Conf {
    Conf -> Text
appId         :: Text
  , Conf -> Text
appKey        :: Text
  , Conf -> Text
appRouter     :: Text
  , Conf -> Integer
appRouterPort :: Integer
  }
  deriving (Conf -> Conf -> Bool
(Conf -> Conf -> Bool) -> (Conf -> Conf -> Bool) -> Eq Conf
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Conf -> Conf -> Bool
$c/= :: Conf -> Conf -> Bool
== :: Conf -> Conf -> Bool
$c== :: Conf -> Conf -> Bool
Eq, Int -> Conf -> ShowS
[Conf] -> ShowS
Conf -> String
(Int -> Conf -> ShowS)
-> (Conf -> String) -> ([Conf] -> ShowS) -> Show Conf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Conf] -> ShowS
$cshowList :: [Conf] -> ShowS
show :: Conf -> String
$cshow :: Conf -> String
showsPrec :: Int -> Conf -> ShowS
$cshowsPrec :: Int -> Conf -> ShowS
Show)

iniParser :: IniParser Conf
iniParser :: IniParser Conf
iniParser = Text -> SectionParser Conf -> IniParser Conf
forall a. Text -> SectionParser a -> IniParser a
section Text
"app" (SectionParser Conf -> IniParser Conf)
-> SectionParser Conf -> IniParser Conf
forall a b. (a -> b) -> a -> b
$ do
  Text
appId         <- Text -> SectionParser Text
field Text
"id"
  Text
appKey        <- Text -> SectionParser Text
field Text
"key"
  Text
appRouter     <- Text -> Text -> SectionParser Text
fieldDef Text
"router" Text
"eu.thethings.network"
  Integer
appRouterPort <- Text
-> (Text -> Either String Integer)
-> Integer
-> SectionParser Integer
forall a. Text -> (Text -> Either String a) -> a -> SectionParser a
fieldDefOf Text
"port" Text -> Either String Integer
forall a. (Num a, Read a, Typeable a) => Text -> Either String a
number Integer
1883
  Conf -> SectionParser Conf
forall (m :: * -> *) a. Monad m => a -> m a
return (Conf -> SectionParser Conf) -> Conf -> SectionParser Conf
forall a b. (a -> b) -> a -> b
$ Conf :: Text -> Text -> Text -> Integer -> Conf
Conf {Integer
Text
appRouterPort :: Integer
appRouter :: Text
appKey :: Text
appId :: Text
appRouterPort :: Integer
appRouter :: Text
appKey :: Text
appId :: Text
..}

-- | Try parsing config from given 'FilePath'
parseConfCfg :: FilePath -> IO (Either String Conf)
parseConfCfg :: String -> IO (Either String Conf)
parseConfCfg String
fpath = do
  Text
rs <- String -> IO Text
Data.Text.IO.readFile String
fpath
  Either String Conf -> IO (Either String Conf)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Conf -> IO (Either String Conf))
-> Either String Conf -> IO (Either String Conf)
forall a b. (a -> b) -> a -> b
$ Text -> IniParser Conf -> Either String Conf
forall a. Text -> IniParser a -> Either String a
parseIniFile Text
rs IniParser Conf
iniParser

-- | Try loading config from location in @TTNCFG@ environment variable
-- or from @~/.ttn/config@
envConfCfg :: IO (Conf)
envConfCfg :: IO Conf
envConfCfg = do
  Maybe String
menv <- String -> IO (Maybe String)
System.Environment.lookupEnv String
"TTNCFG"
  case Maybe String
menv of
    Maybe String
Nothing -> do
      String
udir <- IO String
getHomeDirectory
      let userConf :: String
userConf = String
udir String -> ShowS
</> String
".ttn" String -> ShowS
</> String
"config"
      Bool
hasCfg <- String -> IO Bool
doesFileExist String
userConf
      case Bool
hasCfg of
        Bool
False -> String -> IO ()
putStrLn (String
"Unable to load config: no ~/.ttn/config or TTNCFG env variable set") IO () -> IO Conf -> IO Conf
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Conf
forall a. IO a
exitFailure
        Bool
True -> do
          Either String Conf
res <- String -> IO (Either String Conf)
parseConfCfg String
userConf
          case Either String Conf
res of
            Left String
err -> String -> IO ()
putStrLn (String
"Unable to parse config: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err) IO () -> IO Conf -> IO Conf
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Conf
forall a. IO a
exitFailure
            Right Conf
cfg -> Conf -> IO Conf
forall (m :: * -> *) a. Monad m => a -> m a
return Conf
cfg
    Just String
env -> do
      Either String Conf
res <- String -> IO (Either String Conf)
parseConfCfg String
env
      case Either String Conf
res of
        Left String
err -> String -> IO ()
putStrLn (String
"Unable to parse config: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err) IO () -> IO Conf -> IO Conf
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Conf
forall a. IO a
exitFailure
        Right Conf
cfg -> Conf -> IO Conf
forall (m :: * -> *) a. Monad m => a -> m a
return Conf
cfg

parseType :: Text -> EventType
parseType :: Text -> EventType
parseType Text
t = EventType
typ
  where
    typ :: EventType
typ = case Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
3 [Text]
sp of
      [Text
"up"]                         -> EventType
Up
      [Text
"down"]                       -> EventType
Down
      [Text
"events", Text
"down", Text
"acks"]     -> EventType
DownAcked
      [Text
"events", Text
"down", Text
"sent"]     -> EventType
DownSent
      [Text
"events", Text
"down", Text
"schedule"] -> EventType
DownScheduled
      [Text
"events", Text
"activations"]      -> EventType
Activation
      [Text
"events", Text
"create"]           -> EventType
Create
      [Text
"events", Text
"update"]           -> EventType
Update
      [Text
"events", Text
"delete"]           -> EventType
Delete
      [Text]
_                              -> EventType
Unknown

    sp :: [Text]
sp = Text -> Text -> [Text]
Data.Text.splitOn Text
"/" Text
t

-- | Try to load config from default locations and start actual client
ttnClient :: TChan Event -> IO ()
ttnClient :: TChan Event -> IO ()
ttnClient TChan Event
chan = do
  Conf
conf <- IO Conf
envConfCfg
  Conf -> TChan Event -> IO ()
ttnClientConf Conf
conf TChan Event
chan

-- | Start client with custom `Conf` config
ttnClientConf :: Conf -> TChan Event -> IO ()
ttnClientConf :: Conf -> TChan Event -> IO ()
ttnClientConf Conf{Integer
Text
appRouterPort :: Integer
appRouter :: Text
appKey :: Text
appId :: Text
appRouterPort :: Conf -> Integer
appRouter :: Conf -> Text
appKey :: Conf -> Text
appId :: Conf -> Text
..} TChan Event
chan = do
  let (Just URI
uri) = String -> Maybe URI
Network.URI.parseURI
        (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> String
Data.Text.unpack
        (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Data.Text.concat [ Text
"mqtt://", Text
appId, Text
":", Text
appKey, Text
"@", Text
appRouter ]

  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Connecting to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
uri
  MQTTClient
mc <- MQTTConfig -> URI -> IO MQTTClient
connectURI MQTTConfig
mqttConfig { _msgCB :: MessageCallback
_msgCB = (MQTTClient -> Text -> ByteString -> [Property] -> IO ())
-> MessageCallback
SimpleCallback MQTTClient -> Text -> ByteString -> [Property] -> IO ()
forall p p. p -> Text -> ByteString -> p -> IO ()
msgReceived } URI
uri

  String -> IO ()
putStrLn String
"Connected!"
  IO ([Either SubErr QoS], [Property]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ([Either SubErr QoS], [Property]) -> IO ())
-> IO ([Either SubErr QoS], [Property]) -> IO ()
forall a b. (a -> b) -> a -> b
$ MQTTClient
-> [(Text, SubOptions)]
-> [Property]
-> IO ([Either SubErr QoS], [Property])
subscribe MQTTClient
mc [(Text
"#", SubOptions
subOptions)] [Property]
forall a. Monoid a => a
mempty
  MQTTClient -> IO ()
waitForClient MQTTClient
mc
  where
    msgReceived :: p -> Text -> ByteString -> p -> IO ()
msgReceived p
_ Text
topic ByteString
msg p
_p = do
      case ByteString -> Either String Uplink
parse (ByteString -> ByteString
Data.ByteString.Lazy.toStrict ByteString
msg) of
        Left String
err -> do
          case ByteString -> Either String Error
parseError (ByteString -> ByteString
Data.ByteString.Lazy.toStrict ByteString
msg) of
            Left String
_  -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid JSON, error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
            Right Error
e -> STM () -> IO ()
forall a. STM a -> IO a
atomically
              (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
chan
              (Event -> STM ()) -> Event -> STM ()
forall a b. (a -> b) -> a -> b
$ String -> Event
ClientError
              (String -> Event) -> String -> Event
forall a b. (a -> b) -> a -> b
$ Text -> String
Data.Text.unpack
              (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Error -> Text
errorMsg Error
e

        Right Uplink
x -> do
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
chan (Event -> STM ()) -> Event -> STM ()
forall a b. (a -> b) -> a -> b
$ EventType -> Uplink -> Event
Event (Text -> EventType
parseType Text
topic) Uplink
x

withTTN :: (Event -> IO a) -> IO b
withTTN :: (Event -> IO a) -> IO b
withTTN Event -> IO a
act = do
  TChan Event
c <- IO (TChan Event)
forall a. IO (TChan a)
newTChanIO
  IO (Async Any) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async Any) -> IO ()) -> IO (Async Any) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
async (IO Any -> IO (Async Any)) -> IO Any -> IO (Async Any)
forall a b. (a -> b) -> a -> b
$ IO a -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO a -> IO Any) -> IO a -> IO Any
forall a b. (a -> b) -> a -> b
$ do
    Event
msg <- STM Event -> IO Event
forall a. STM a -> IO a
atomically (STM Event -> IO Event) -> STM Event -> IO Event
forall a b. (a -> b) -> a -> b
$ TChan Event -> STM Event
forall a. TChan a -> STM a
readTChan TChan Event
c
    Event -> IO a
act Event
msg

  IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
catches (TChan Event -> IO ()
ttnClient TChan Event
c)
    [ (MQTTException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(MQTTException
ex :: MQTTException) -> String -> IO ()
handler (MQTTException -> String
forall a. Show a => a -> String
show MQTTException
ex))
    , (IOException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(IOException
ex :: IOException) -> String -> IO ()
handler (IOException -> String
forall a. Show a => a -> String
show IOException
ex)) ]

  where
    handler :: String -> IO ()
handler String
e = String -> IO ()
putStrLn (String
"ERROR: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
threadDelay Int
1000000