Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# LANGUAGE OverloadedStrings #-}
- {-# LANGUAGE FlexibleContexts #-}
- {-# LANGUAGE ScopedTypeVariables #-}
- {-# OPTIONS_GHC -fno-warn-unused-binds #-}
- -- -fno-warn-unused-matches.
- module Vertigo.Dsl.RunLight (runLight) where
- import Control.Exception (SomeException(..), throw)
- import Control.Exception.Enclosed (tryAny)
- import Control.Lens ((&), (?~), (^.), view)
- import Control.Monad.Except (MonadError, lift)
- import Control.Monad.Free (iterM)
- import Control.Monad.Catch (MonadThrow)
- import Control.Monad.IO.Class (MonadIO, liftIO)
- import Control.Monad.Reader (MonadReader, ask, asks)
- import Control.Monad.Trans.Control (MonadBaseControl)
- import Control.Monad.Trans.Resource(runResourceT)
- import Data.HashMap.Strict (toList)
- import Data.Aeson (decode, encode)
- import Data.Maybe (fromMaybe, fromJust)
- import Data.Monoid ((<>))
- import Data.Text (Text, pack, unpack)
- import Data.Text.Encoding (encodeUtf8)
- import Network.HTTP.Client (Manager, Request(..), Response(..))
- import Network.HTTP.Conduit (RequestBody(..), httpLbs, parseUrl)
- import qualified Data.ByteString.Char8 as B
- import qualified Data.Map as M
- import qualified System.Logging.Facade as Log
- import Vertigo.Dsl.Notify
- import Vertigo.Ext (Ext, awsEnv, manager, userServiceUrl)
- import Vertigo.Token (createToken)
- import Vertigo.Types.DeviceInfo
- import Vertigo.Types.Error (MyException(MyException), ErrorEnum (..))
- import qualified Vertigo.Types.Notification.Ids as N
- import qualified Vertigo.Types.Notification.UserCore as N
- import qualified Vertigo.Types.Notification.Vuid as N
- -- run the service without SNS, it's behavior is emulated
- runLight :: (MonadBaseControl IO m, MonadError ErrorEnum m, MonadIO m, MonadReader Ext m, MonadThrow m, Log.Logging m) =>
- FreeNotifyDsl a -> m a
- runLight fnd = do
- -- m is the manager from Ext
- m <- asks (^. manager)
- iterM (run m) fnd
- where
- run :: (MonadBaseControl IO m, MonadError ErrorEnum m, MonadIO m, MonadReader Ext m, MonadThrow m, Log.Logging m) =>
- Manager -> NotifyDsl (m a) -> m a
- run m (UserServiceGetUser uid next) = do
- let meth = "UserServiceGetDevices: "
- Log.debug $ meth <> show uid
- user0 <- userServiceGetUser_ m uid
- Log.debug $ meth <> show user0
- case user0 of
- Left err -> do
- Log.debug $ meth <> " err = " <> show err
- next Nothing
- Right usr -> next $ Just usr
- run m (UserServiceGetDevices uid next) = do
- let meth = "UserServiceGetDevices: "
- Log.debug $ meth <> show uid
- devices0 <- userServiceGetDevices_ m uid
- Log.debug $ meth <> show devices0
- case devices0 of
- Left err -> do
- Log.debug $ meth <> show err
- next Nothing
- Right des -> next $ Just des
- run m (UserServiceUpdateDevice uid device next) = do
- let meth = "UserServiceUpdateDevice: "
- Log.debug $ meth <> show uid
- r0 <- userServiceUpdateDevice_ m uid device
- Log.debug $ meth <> show r0
- next
- run _m (SnsCreatePlatformEndpoint applicationArn deviceToken customData next) = do
- let meth = "SnsCreatePlatformEndpoint: "
- Log.debug $ meth <> show applicationArn
- r0 <- snsCreatePlatformEndpoint_ applicationArn deviceToken customData
- case r0 of
- Left err -> do
- Log.debug $ meth <> show err
- next Nothing
- Right endpArn -> next $ Just endpArn
- run _m (SnsPublish endpointArn msg next) = do
- let meth = "SnsPublish: "
- Log.debug $ meth <> show (endpointArn, msg)
- r0 <- snsPublish_ endpointArn msg
- case r0 of
- Left err -> do
- Log.debug $ meth <> show err
- next Nothing
- Right _ -> next $ Just ()
- run _m (SnsGetEndpointAttributes endpointArn next) = do
- let meth = "SnsGetEndpointAttributes: "
- Log.debug $ meth <> show endpointArn
- r0 <- snsGetEndpointAttributes_ endpointArn
- Log.debug $ meth <> show r0
- case r0 of
- Left err -> do
- Log.debug $ meth <> show err
- next Nothing
- Right attributes ->
- next $ Just attributes
- run _m (SnsDeleteEndpoint endpointArn next) = do
- let meth = "SnsDeleteEndpoint: "
- Log.debug $ meth <> show endpointArn
- r0 <- snsDeleteEndpoint_ endpointArn
- Log.debug $ meth <> show r0
- case r0 of
- Left err -> Log.debug $ meth <> show err
- Right _ -> return ()
- next
- -- concatenate and create access token for other services call
- prepareRequest :: MonadThrow m => Text -> Ext -> Text -> m Request
- prepareRequest endpoint ext token = do
- let url = ext ^. userServiceUrl
- rq <- parseUrl $ unpack $ url <> endpoint
- return rq
- { redirectCount = 0
- , requestHeaders = ("X-Access-Token", encodeUtf8 token): requestHeaders rq
- }
- -- call to http://user.qavmg.com/rest/profile/305bc11d-66dd-4577-84c9-2af0b3578949
- userServiceGetUser_ :: (MonadBaseControl IO m, MonadIO m, MonadReader Ext m, MonadThrow m, Log.Logging m) =>
- Manager -> N.UserId -> m (Either SomeException N.UserCore)
- userServiceGetUser_ manager uid = tryAny $ do
- ext <- ask
- token <- createToken uid
- let N.UserId vid = uid
- rawJson <- liftIO $ runResourceT $ do
- req <- prepareRequest ("/profile/" <> N.toText vid) ext token
- lift $ Log.debug $ "req = " <> show req
- res <- httpLbs req manager
- return $ responseBody res
- let usrMb = decode rawJson :: Maybe N.UserCore
- return $ fromMaybe (throw $ MyException "User not found") usrMb
- -- call to http://user.qavmg.com/rest/device
- -- token is the user
- userServiceGetDevices_ :: (MonadBaseControl IO m, MonadIO m, MonadReader Ext m, MonadThrow m, Log.Logging m) =>
- Manager -> N.UserId -> m (Either SomeException [DeviceInfo])
- userServiceGetDevices_ manager uid = tryAny $ do
- ext <- ask
- token <- createToken uid
- rawJson <- liftIO $ runResourceT $ do
- req <- prepareRequest "/device" ext token
- lift $ Log.debug $ "req = " <> show req
- res <- httpLbs req manager
- return $ responseBody res
- let dsMb = decode rawJson :: Maybe [DeviceInfo]
- return $ fromMaybe [] dsMb
- -- | userServiceUpdateDevice
- -- update the device info
- userServiceUpdateDevice_ :: (MonadBaseControl IO m, MonadIO m, MonadReader Ext m, MonadThrow m, Log.Logging m) =>
- Manager -> N.UserId -> DeviceInfo -> m (Either SomeException ())
- userServiceUpdateDevice_ manager uid device = tryAny $ do
- ext <- ask
- token <- createToken uid
- _rawJson <- liftIO $ runResourceT $ do
- req <- prepareRequest_ ext token device
- lift $ Log.debug $ "req = " <> show req
- res <- httpLbs req manager
- return $ responseBody res
- return ()
- where
- prepareRequest_ ext token device = do
- let url = ext ^. userServiceUrl
- req0 <- parseUrl $ unpack url
- -- update should be in the form of PUT /rest/device/123456 where 123456 is diDeviceId
- let newPath :: B.ByteString
- newPath = path req0 <> "/device/" <> encodeUtf8 (device ^. diDeviceId)
- return req0
- { method = "PUT"
- , path = newPath
- , redirectCount = 0
- , requestBody = RequestBodyLBS $ encode device
- , requestHeaders =
- ("X-Access-Token", encodeUtf8 token):
- ("Content-Type", "application/json"):
- requestHeaders req0
- }
- -- paArn - platformApplicationARN
- -- deviceToken - device token for iOS or registrationId for Android
- snsCreatePlatformEndpoint_ :: (MonadBaseControl IO m, MonadIO m, MonadReader Ext m, Log.Logging m) =>
- ApplicationArn -> DeviceToken -> Text -> m (Either SomeException EndpointArn)
- snsCreatePlatformEndpoint_ (ApplicationArn paArn) (DeviceToken deviceToken) customData = tryAny $ do
- -- TODO return arn:aws:sns:us-west-2:877422789438:endpoint/APNS/vertigo-ios-dev-prod/610edbfa-b5ca-3275-ab07-100a5c10310f
- EndpointArn <$> return "arn:aws:sns:us-west-2:877422789438:endpoint/APNS/vertigo-ios-dev-prod/610edbfa-b5ca-3275-ab07-100a5c10310f"
- -- endpointArn - endpointArn of the device to send message to
- -- msq - message to send
- snsPublish_ :: (MonadBaseControl IO m, MonadIO m, MonadReader Ext m) =>
- EndpointArn -> Text -> m (Either SomeException ())
- snsPublish_ (EndpointArn endpointArn) msg = tryAny $ do
- return ()
- snsGetEndpointAttributes_ :: (MonadBaseControl IO m, MonadIO m, MonadReader Ext m) =>
- EndpointArn -> m (Either SomeException (M.Map Text Text))
- snsGetEndpointAttributes_ (EndpointArn endpointArn) = tryAny $ do
- return $ M.fromList $ [(pack "size", pack "10")]
- snsDeleteEndpoint_ :: (MonadBaseControl IO m, MonadIO m, MonadReader Ext m) =>
- EndpointArn -> m (Either SomeException ())
- snsDeleteEndpoint_ (EndpointArn endpointArn) = tryAny $ do
- return ()
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement