diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +0.5 +--- +* Switch to `servant-0.7` (see [#5](https://github.com/GetShopTV/smsaero/pull/5)); +* Update to the latest SMSAero API (see [#7](https://github.com/GetShopTV/smsaero/pull/7) and [#9](https://github.com/GetShopTV/smsaero/pull/9) and [#10](https://github.com/GetShopTV/smsaero/pull/10)): + * Add `type` parameter; + * Add groups, contacts and blacklist API; + * Add API for tarif and message status checking. + 0.4.1 --- * Add `Eq` instances diff --git a/smsaero.cabal b/smsaero.cabal --- a/smsaero.cabal +++ b/smsaero.cabal @@ -1,5 +1,5 @@ name: smsaero -version: 0.4.1 +version: 0.5 synopsis: SMSAero API and HTTP client based on servant library. description: Please see README.md homepage: https://github.com/GetShopTV/smsaero @@ -18,21 +18,23 @@ cabal-version: >=1.10 library + ghc-options: -Wall hs-source-dirs: src exposed-modules: SMSAero SMSAero.API SMSAero.Client - SMSAero.Utils + SMSAero.Types build-depends: base >= 4.7 && < 5 - , either - , servant == 0.4.* + , servant >= 0.7.1 , servant-client , servant-docs + , http-api-data >= 0.2.3 + , http-client , aeson , text , time - , lens + , containers default-language: Haskell2010 source-repository head diff --git a/src/SMSAero.hs b/src/SMSAero.hs --- a/src/SMSAero.hs +++ b/src/SMSAero.hs @@ -8,8 +8,10 @@ -- SMSAero API and HTTP client. module SMSAero ( module SMSAero.API, - module SMSAero.Client + module SMSAero.Client, + module SMSAero.Types, ) where import SMSAero.API +import SMSAero.Types import SMSAero.Client diff --git a/src/SMSAero/API.hs b/src/SMSAero/API.hs --- a/src/SMSAero/API.hs +++ b/src/SMSAero/API.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-orphans #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -22,51 +23,60 @@ -- * API SMSAeroAPI, SendApi, + SendToGroupApi, StatusApi, + GroupApi, + PhoneApi, + BlacklistApi, -- * Combinators SmsAeroJson, AnswerJson, RequireAuth, RequiredQueryParam, SmsAeroGet, - -- * Types - SMSAeroAuth(..), - Signature(..), - MessageId(..), - MessageBody(..), - Phone(..), - SMSAeroDate(..), -- * Responses SmsAeroResponse(..), SendResponse(..), MessageStatus(..), + CheckSendingResponse, BalanceResponse(..), + CheckTariffResponse, SendersResponse(..), SignResponse(..), + GroupResponse(..), + PhoneResponse(..), + BlacklistResponse(..), ) where import Data.Aeson -import Data.Int (Int64) import Data.Proxy import Data.Time (UTCTime(UTCTime)) import Data.Time.Calendar (fromGregorian) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) import Data.Text (Text) import qualified Data.Text as Text +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.Maybe (catMaybes) + import Control.Applicative +import Control.Arrow ((***)) import GHC.TypeLits (Symbol, KnownSymbol) -import Text.Read (readMaybe) import Servant.API import Servant.Client import Servant.Docs -import Control.Lens (over, (|>)) +import Servant.Docs.Internal (_params) +import Web.HttpApiData + import GHC.Generics +import SMSAero.Types + -- | Content type for SMSAero JSON answer (it has JSON body but "text/plain" Content-Type). data SmsAeroJson @@ -82,9 +92,9 @@ -- | Like 'QueryParam', but always required. data RequiredQueryParam (sym :: Symbol) a -instance (HasClient sub, KnownSymbol sym, ToText a) => HasClient (RequiredQueryParam sym a :> sub) where +instance (HasClient sub, KnownSymbol sym, ToHttpApiData a) => HasClient (RequiredQueryParam sym a :> sub) where type Client (RequiredQueryParam sym a :> sub) = a -> Client sub - clientWithRoute _ req baseurl param = clientWithRoute (Proxy :: Proxy (QueryParam sym a :> sub)) req baseurl (Just param) + clientWithRoute _ req param = clientWithRoute (Proxy :: Proxy (QueryParam sym a :> sub)) req (Just param) instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sub) => HasDocs (RequiredQueryParam sym a :> sub) where docsFor _ (endpoint, action) = @@ -92,47 +102,8 @@ where subP = Proxy :: Proxy sub paramP = Proxy :: Proxy (QueryParam sym a) - action' = over params (|> toParam paramP) action - --- | SMSAero sender's signature. This is used for the "from" field. -newtype Signature = Signature { getSignature :: Text } deriving (Eq, Show, FromJSON, ToJSON, ToText, FromText) - --- | SMSAero sent message id. -newtype MessageId = MessageId Int64 deriving (Eq, Show, FromJSON, ToJSON, ToText, FromText) - --- | SMSAero message body. -newtype MessageBody = MessageBody Text deriving (Eq, Show, FromJSON, ToJSON, ToText, FromText) - --- | SMSAero authentication data. -data SMSAeroAuth = SMSAeroAuth - { authUser :: Text -- ^ Username. - , authPassword :: Text -- ^ MD5 hash of a password. - } - -instance FromJSON SMSAeroAuth where - parseJSON (Object o) = SMSAeroAuth - <$> o .: "user" - <*> o .: "password" - parseJSON _ = empty - -instance ToJSON SMSAeroAuth where - toJSON SMSAeroAuth{..} = object - [ "user" .= authUser - , "password" .= authPassword ] - --- | Phone number. -newtype Phone = Phone { getPhone :: Int64 } deriving (Eq, Show, ToText, FromText) - --- | Date. Textually @SMSAeroDate@ is represented as a number of seconds since 01 Jan 1970. -newtype SMSAeroDate = SMSAeroDate { getSMSAeroDate :: UTCTime } deriving (Eq, Show) - -instance ToText SMSAeroDate where - toText (SMSAeroDate dt) = Text.pack (show (utcTimeToPOSIXSeconds dt)) - -instance FromText SMSAeroDate where - fromText s = do - n <- fromInteger <$> readMaybe (Text.unpack s) - return (SMSAeroDate (posixSecondsToUTCTime n)) + action' = action { _params = params' } + params' = _params action ++ [toParam paramP] -- | SMSAero authentication credentials. data RequireAuth @@ -140,13 +111,12 @@ instance HasClient sub => HasClient (RequireAuth :> sub) where type Client (RequireAuth :> sub) = SMSAeroAuth -> Client sub - clientWithRoute _ req baseurl SMSAeroAuth{..} = + clientWithRoute _ req SMSAeroAuth{..} = clientWithRoute (Proxy :: Proxy (RequiredQueryParam "user" Text :> RequiredQueryParam "password" Text :> sub)) req - baseurl authUser authPassword @@ -163,14 +133,15 @@ ["5f4dcc3b5aa765d61d8327deb882cf99", "d8578edf8458ce06fbc5bb76a58c5ca4"] "MD5 hash of a password." Normal - action' = over params ((|> passP) . (|> userP)) action + action' = action { _params = params' } + params' = _params action ++ [userP, passP] -- | Implicit parameter that tells SMSAero to respond with JSON. data AnswerJson instance HasClient sub => HasClient (AnswerJson :> sub) where type Client (AnswerJson :> sub) = Client sub - clientWithRoute _ req baseurl = clientWithRoute (Proxy :: Proxy (RequiredQueryParam "answer" Text :> sub)) req baseurl "json" + clientWithRoute _ req = clientWithRoute (Proxy :: Proxy (RequiredQueryParam "answer" Text :> sub)) req "json" instance HasDocs sub => HasDocs (AnswerJson :> sub) where docsFor _ (endpoint, action) = docsFor subP (endpoint, action') @@ -180,25 +151,34 @@ ["json"] "When present makes SMSAero REST API to respond with JSON." Normal - action' = over params (|> answerP) action + action' = action { _params = params' } + params' = _params action ++ [answerP] -- | Regular SMSAero GET API. type SmsAeroGet a = Get '[SmsAeroJson] (SmsAeroResponse a) -- | SMSAero API. type SMSAeroAPI = RequireAuth :> AnswerJson :> - ("send" :> SendApi - :<|> "status" :> StatusApi - :<|> "balance" :> SmsAeroGet BalanceResponse - :<|> "senders" :> SmsAeroGet SendersResponse - :<|> "sign" :> SmsAeroGet SignResponse) + ("send" :> SendApi + :<|> "sendtogroup" :> SendToGroupApi + :<|> "status" :> StatusApi + :<|> "checksending" :> CheckSendingApi + :<|> "balance" :> SmsAeroGet BalanceResponse + :<|> "checktarif" :> SmsAeroGet CheckTariffResponse + :<|> "senders" :> SmsAeroGet SendersResponse + :<|> "sign" :> SmsAeroGet SignResponse + :<|> GroupApi + :<|> PhoneApi + :<|> "addblacklist" :> BlacklistApi) -- | SMSAero API to send a message. type SendApi = RequiredQueryParam "to" Phone :> RequiredQueryParam "text" MessageBody :> RequiredQueryParam "from" Signature :> - QueryParam "date" SMSAeroDate :> + QueryParam "date" SMSAeroDate :> + QueryParam "type" SendType :> + QueryParam "digital" DigitalChannel :> SmsAeroGet SendResponse instance ToParam (QueryParam "to" Phone) where @@ -221,10 +201,38 @@ instance ToParam (QueryParam "date" SMSAeroDate) where toParam _ = DocQueryParam "date" - [show (utcTimeToPOSIXSeconds (UTCTime (fromGregorian 2015 01 31) 0))] + [Text.unpack (toQueryParam (SMSAeroDate (UTCTime (fromGregorian 2015 01 31) 0)))] "Requested datetime of delivery as number of seconds since 01 Jan 1970." Normal +instance ToParam (QueryParam "type" SendType) where + toParam _ = DocQueryParam "type" + (map (Text.unpack . toQueryParam) [minBound..maxBound::SendType]) + "Send type to describe send channel, equals to '2' (free literal signature for all operators except MTS) by default. Can't be used with 'digital' parameter." + Normal + +instance ToParam (QueryParam "digital" DigitalChannel) where + toParam _ = DocQueryParam "digital" + [Text.unpack (toQueryParam DigitalChannel)] + "Send type for digital send channel. Can't be used with 'type' parameter." + Normal + +-- | SMSAero API to send a group message. +type SendToGroupApi = + RequiredQueryParam "group" Group :> + RequiredQueryParam "text" MessageBody :> + RequiredQueryParam "from" Signature :> + QueryParam "date" SMSAeroDate :> + QueryParam "type" SendType :> + QueryParam "digital" DigitalChannel :> + SmsAeroGet SendResponse + +instance ToParam (QueryParam "group" Group) where + toParam _ = DocQueryParam "group" + ["all", "groupname"] + "Group name to broadcast a message." + Normal + -- | SMSAero API to check message status. type StatusApi = RequiredQueryParam "id" MessageId :> SmsAeroGet MessageStatus @@ -234,6 +242,31 @@ "Message ID, returned previously by SMSAero." Normal +-- | SMSAero API to check broadcast status. +type CheckSendingApi = RequiredQueryParam "id" MessageId :> SmsAeroGet CheckSendingResponse + +-- | SMSAero API to add/delete groups. +type GroupApi = + "checkgroup" :> SmsAeroGet [Group] + :<|> "addgroup" :> RequiredQueryParam "group" Group :> SmsAeroGet GroupResponse + :<|> "delgroup" :> RequiredQueryParam "group" Group :> SmsAeroGet GroupResponse + +-- | SMSAero API to add/delete subscribers. +type PhoneApi = + "addphone" :> + RequiredQueryParam "phone" Phone :> + QueryParam "group" Group :> + QueryParam "lname" Name :> + QueryParam "fname" Name :> + QueryParam "sname" Name :> + QueryParam "bday" BirthDate :> + QueryParam "param" Text :> + SmsAeroGet PhoneResponse + :<|> "delphone" :> RequiredQueryParam "phone" Phone :> QueryParam "group" Group :> SmsAeroGet PhoneResponse + +-- | SMSAero API to add phone to blacklist. +type BlacklistApi = RequiredQueryParam "phone" Phone :> SmsAeroGet BlacklistResponse + -- | Every SMSAero response is either rejected or provides some info. data SmsAeroResponse a = ResponseOK a -- ^ Some useful payload. @@ -246,7 +279,7 @@ | SendNoCredits -- ^ No credits to send a message. deriving (Eq, Show, Generic) -instance ToSample (SmsAeroResponse SendResponse) (SmsAeroResponse SendResponse) where +instance ToSample (SmsAeroResponse SendResponse) where toSamples _ = [ ("When message is sent successfully.", ResponseOK (SendAccepted (MessageId 12345))) , ("When SMSAero account does not have enough credit.", ResponseOK SendNoCredits) @@ -262,26 +295,30 @@ | StatusWaitStatus -- ^ Wait for message status. deriving (Eq, Enum, Bounded, Show, Read, Generic) -instance ToSample (SmsAeroResponse MessageStatus) (SmsAeroResponse MessageStatus) where +instance ToSample (SmsAeroResponse MessageStatus) where toSamples _ = [ ("When message has been delivered successfully.", ResponseOK StatusDeliverySuccess) , ("When message has been queued.", ResponseOK StatusQueue) ] --- | SMSAero response to a balance request. --- This is a number of available messages to send. +-- | SMSAero response to a balance request (balance in rubles). newtype BalanceResponse = BalanceResponse Double deriving (Eq, Show) -instance ToSample (SmsAeroResponse BalanceResponse) (SmsAeroResponse BalanceResponse) where +instance ToSample (SmsAeroResponse BalanceResponse) where toSamples _ = [ ("Just balance.", ResponseOK (BalanceResponse 247)) , ("When auth credentials are incorrect.", ResponseReject "incorrect user or password") ] --- | SMSAero response to a senders request. +-- | SMSAero response to a checktarif request. +type CheckTariffResponse = Map ChannelName Double + +-- | SMSAero response to a checksending request. +type CheckSendingResponse = Map MessageId MessageStatus + -- This is just a list of available signatures. newtype SendersResponse = SendersResponse [Signature] deriving (Eq, Show, FromJSON, ToJSON) -instance ToSample (SmsAeroResponse SendersResponse) (SmsAeroResponse SendersResponse) where - toSample _ = Just (ResponseOK (SendersResponse [Signature "TEST", Signature "My Company"])) +instance ToSample (SmsAeroResponse SendersResponse) where + toSamples _ = singleSample (ResponseOK (SendersResponse [Signature "TEST", Signature "My Company"])) -- | SMSAero response to a sign request. data SignResponse @@ -290,11 +327,20 @@ | SignPending -- ^ Signature is pending. deriving (Eq, Enum, Bounded, Show, Generic) -instance ToSample (SmsAeroResponse SignResponse) (SmsAeroResponse SignResponse) where +instance ToSample (SmsAeroResponse SignResponse) where toSamples _ = [ ("When a new signature is approved.", ResponseOK SignApproved) , ("When a new signature is rejected.", ResponseOK SignRejected) ] +-- | SMSAero response to an addgroup/delgroup request. +newtype GroupResponse = GroupResponse Text deriving (Eq, Show, FromJSON, ToJSON) + +-- | SMSAero response to an addphone/delphone request. +newtype PhoneResponse = PhoneResponse Text deriving (Eq, Show, FromJSON, ToJSON) + +-- | SMSAero response to an addblacklist request. +newtype BlacklistResponse = BlacklistResponse Text deriving (Eq, Show, FromJSON, ToJSON) + instance FromJSON a => FromJSON (SmsAeroResponse a) where parseJSON (Object o) = do result :: Maybe Text <- o .:? "result" @@ -325,32 +371,27 @@ toJSON SendNoCredits = object [ "result" .= ("no credits" :: Text)] --- | Helper to define @fromText@ matching @toText@. -boundedFromText :: (Enum a, Bounded a, ToText a) => Text -> Maybe a -boundedFromText = flip lookup xs - where - vals = [minBound..maxBound] - xs = zip (map toText vals) vals - -instance FromText MessageStatus where - fromText = boundedFromText +instance FromHttpApiData MessageStatus where + parseQueryParam = parseBoundedQueryParam -instance ToText MessageStatus where - toText StatusDeliverySuccess = "delivery success" - toText StatusDeliveryFailure = "delivery failure" - toText StatusSmscSubmit = "smsc submit" - toText StatusSmscReject = "smsc reject" - toText StatusQueue = "queue" - toText StatusWaitStatus = "wait status" +instance ToHttpApiData MessageStatus where + toQueryParam StatusDeliverySuccess = "delivery success" + toQueryParam StatusDeliveryFailure = "delivery failure" + toQueryParam StatusSmscSubmit = "smsc submit" + toQueryParam StatusSmscReject = "smsc reject" + toQueryParam StatusQueue = "queue" + toQueryParam StatusWaitStatus = "wait status" instance FromJSON MessageStatus where parseJSON (Object o) = do result :: Text <- o .: "result" - maybe empty pure (fromText result) + case (parseUrlPiece result :: Either Text MessageStatus) of + Left _ -> empty + Right status -> return status parseJSON _ = empty instance ToJSON MessageStatus where - toJSON status = object [ "result" .= toText status ] + toJSON status = object [ "result" .= toUrlPiece status ] instance FromJSON BalanceResponse where parseJSON (Object o) = BalanceResponse <$> o .: "balance" @@ -359,19 +400,31 @@ instance ToJSON BalanceResponse where toJSON (BalanceResponse n) = object [ "balance" .= n ] -instance ToText SignResponse where - toText SignApproved = "approved" - toText SignRejected = "rejected" - toText SignPending = "pending" +instance ToHttpApiData SignResponse where + toQueryParam SignApproved = "approved" + toQueryParam SignRejected = "rejected" + toQueryParam SignPending = "pending" -instance FromText SignResponse where - fromText = boundedFromText +instance FromHttpApiData SignResponse where + parseQueryParam = parseBoundedQueryParam instance FromJSON SignResponse where parseJSON (Object o) = do accepted :: Text <- o .: "accepted" - maybe empty pure (fromText accepted) + case (parseUrlPiece accepted :: Either Text SignResponse) of + Left _ -> empty + Right resp -> return resp parseJSON _ = empty instance ToJSON SignResponse where - toJSON s = object [ "accepted" .= toText s ] + toJSON s = object [ "accepted" .= toUrlPiece s ] + +instance ToJSON CheckSendingResponse where + toJSON = toJSON . Map.mapKeys toQueryParam . fmap toQueryParam + +instance FromJSON CheckSendingResponse where + parseJSON js = + Map.fromList . catMaybes . map dist . map (parseQueryParamMaybe *** parseQueryParamMaybe) . Map.toList <$> parseJSON js + where + dist (x, y) = (,) <$> x <*> y + diff --git a/src/SMSAero/Client.hs b/src/SMSAero/Client.hs --- a/src/SMSAero/Client.hs +++ b/src/SMSAero/Client.hs @@ -6,40 +6,150 @@ -- Stability : experimental -- -- SMSAero HTTP servant client and individual client functions. -module SMSAero.Client where - -import Control.Monad.Trans.Either +module SMSAero.Client ( + -- * Client + smsAeroClient, + defaultBaseUrl, + SmsAero, + -- * Sending a message + smsAeroSend, + smsAeroSendToGroup, + -- * Checking status + smsAeroStatus, + smsAeroCheckSending, + -- * Checking balance and tariff + smsAeroBalance, + smsAeroCheckTariff, + -- * Signatures + smsAeroSenders, + smsAeroSign, + -- * Groups + smsAeroListGroups, + smsAeroAddGroup, + smsAeroDeleteGroup, + -- * Contacts + smsAeroAddPhone, + smsAeroDeletePhone, + -- * Blacklist + smsAeroAddToBlacklist, +) where import Data.Proxy +import Data.Text (Text) import Servant.API import Servant.Client import SMSAero.API -import SMSAero.Utils +import SMSAero.Types +import Network.HTTP.Client (Manager) + -- | SMSAero client. smsAeroClient :: Client SMSAeroAPI -smsAeroClient = client (Proxy :: Proxy SMSAeroAPI) host - where - host = BaseUrl Https "gate.smsaero.ru" 443 +smsAeroClient = client (Proxy :: Proxy SMSAeroAPI) +-- | Default host @https://gate.smsaero.ru@. +defaultBaseUrl :: BaseUrl +defaultBaseUrl = BaseUrl Https "gate.smsaero.ru" 443 "" + -- | Common SMSAero client type. -type SmsAero a = EitherT ServantError IO (SmsAeroResponse a) +type SmsAero a = Manager -> BaseUrl -> ClientM (SmsAeroResponse a) -- | Send a message. -smsAeroSend :: SMSAeroAuth -> Phone -> MessageBody -> Signature -> Maybe SMSAeroDate -> SmsAero SendResponse +smsAeroSend :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> Phone -- ^ Phone number to send a message to. + -> MessageBody -- ^ Message text. + -> Signature -- ^ Sender's signature used for the "from" field. + -> Maybe SMSAeroDate -- ^ Date stating when to send a postponed message. + -> Maybe SendType -- ^ Send channel description. + -> Maybe DigitalChannel -- ^ Use digital send channel. + -> SmsAero SendResponse + +-- | Send a group message. +smsAeroSendToGroup :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> Group -- ^ Group name for broadcasting a message. + -> MessageBody -- ^ Message text. + -> Signature -- ^ Sender's signature used for the "from" field. + -> Maybe SMSAeroDate -- ^ Date stating when to send a postponed message. + -> Maybe SendType -- ^ Send channel description. + -> Maybe DigitalChannel -- ^ Use digital send channel. + -> SmsAero SendResponse + -- | Check status of a previously sent message. -smsAeroStatus :: SMSAeroAuth -> MessageId -> SmsAero MessageStatus +smsAeroStatus :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> MessageId -- ^ Message ID. + -> SmsAero MessageStatus + +-- | Check status of a broadcast. +smsAeroCheckSending :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> MessageId -- ^ Broadcast ID. + -> SmsAero CheckSendingResponse + -- | Check balance. -smsAeroBalance :: SMSAeroAuth -> SmsAero BalanceResponse +smsAeroBalance :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> SmsAero BalanceResponse + +-- | Check tariff. +smsAeroCheckTariff :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> SmsAero CheckTariffResponse + -- | Check the list of available sender signatures. -smsAeroSenders :: SMSAeroAuth -> SmsAero SendersResponse +smsAeroSenders :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> SmsAero SendersResponse + -- | Acquire a new signature. -smsAeroSign :: SMSAeroAuth -> SmsAero SignResponse -(smsAeroSend :<|> - smsAeroStatus :<|> - smsAeroBalance :<|> - smsAeroSenders :<|> - smsAeroSign) = distributeClient smsAeroClient +smsAeroSign :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> SmsAero SignResponse + +-- | Get groups list (corresponds to 'checkgroup' endpoint). +smsAeroListGroups :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> SmsAero [Group] + +-- | Add a group. +smsAeroAddGroup :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> Group -- ^ Name for the new group. + -> SmsAero GroupResponse + +-- | Delete a group. +smsAeroDeleteGroup :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> Group -- ^ Name of the group to be deleted. + -> SmsAero GroupResponse + +-- | Add a phone to contact list or group. +smsAeroAddPhone :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> Phone -- ^ Subscriber's phone number. + -> Maybe Group -- ^ Contact group. If absent, contact will be added to general contact list. + -> Maybe Name -- ^ Subscriber's last name. + -> Maybe Name -- ^ Subscriber's first name. + -> Maybe Name -- ^ Subscriber's middle name. + -> Maybe BirthDate -- ^ Subscriber's birth date. + -> Maybe Text -- ^ Any additional information. + -> SmsAero PhoneResponse + +-- | Delete a phone from contact list or group. +smsAeroDeletePhone :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password). + -> Phone -- ^ Subscriber's phone number. + -> Maybe Group -- ^ Group to remove contact from. If absent, contact will be deleted from general contact list. + -> SmsAero PhoneResponse + +-- | Add a phone number to blacklist. +smsAeroAddToBlacklist :: SMSAeroAuth -- ^ Authentication data (login and MD5 hash of password) + -> Phone -- ^ Phone number to be added to blacklist. + -> SmsAero BlacklistResponse + +smsAeroSend auth = let (f :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _) = smsAeroClient auth in f +smsAeroSendToGroup auth = let (_ :<|> f :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _) = smsAeroClient auth in f +smsAeroStatus auth = let (_ :<|> _ :<|> f :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _) = smsAeroClient auth in f +smsAeroCheckSending auth = let (_ :<|> _ :<|> _ :<|> f :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _) = smsAeroClient auth in f +smsAeroBalance auth = let (_ :<|> _ :<|> _ :<|> _ :<|> f :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _) = smsAeroClient auth in f +smsAeroCheckTariff auth = let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> f :<|> _ :<|> _ :<|> _ :<|> _ :<|> _) = smsAeroClient auth in f +smsAeroSenders auth = let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> f :<|> _ :<|> _ :<|> _ :<|> _) = smsAeroClient auth in f +smsAeroSign auth = let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> f :<|> _ :<|> _ :<|> _) = smsAeroClient auth in f +smsAeroListGroups auth = let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> (f :<|> _ :<|> _) :<|> _ :<|> _) = smsAeroClient auth in f +smsAeroAddGroup auth = let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> (_ :<|> f :<|> _) :<|> _ :<|> _) = smsAeroClient auth in f +smsAeroDeleteGroup auth = let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> (_ :<|> _ :<|> f) :<|> _ :<|> _) = smsAeroClient auth in f +smsAeroAddPhone auth = let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> (f :<|> _) :<|> _) = smsAeroClient auth in f +smsAeroDeletePhone auth = let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> (_ :<|> f) :<|> _) = smsAeroClient auth in f +smsAeroAddToBlacklist auth = let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> f) = smsAeroClient auth in f diff --git a/src/SMSAero/Types.hs b/src/SMSAero/Types.hs new file mode 100644 --- /dev/null +++ b/src/SMSAero/Types.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : SMSAero.Types +-- Copyright : (c) 2016, GetShopTV +-- License : BSD3 +-- Maintainer : nickolay@getshoptv.com +-- Stability : experimental +-- +-- This module defines types used in SMSAero API. +module SMSAero.Types ( + SMSAeroAuth(..), + Signature(..), + MessageId(..), + MessageBody(..), + Group(..), + Phone(..), + SMSAeroDate(..), + SendType(..), + DigitalChannel(..), + Name(..), + BirthDate(..), + ChannelName, +) where + +import Control.Applicative (empty) + +import Data.Aeson +import Data.Int (Int64) + +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) + +import Data.Text (Text) +import qualified Data.Text as Text + +import Web.HttpApiData.Internal + +-- | SMSAero sender's signature. This is used for the "from" field. +newtype Signature = Signature { getSignature :: Text } deriving (Eq, Show, FromJSON, ToJSON, ToHttpApiData, FromHttpApiData) + +-- | SMSAero sent message id. +newtype MessageId = MessageId Int64 deriving (Eq, Show, Ord, FromJSON, ToJSON, ToHttpApiData, FromHttpApiData) + +-- | SMSAero message body. +newtype MessageBody = MessageBody Text deriving (Eq, Show, FromJSON, ToJSON, ToHttpApiData, FromHttpApiData) + +-- | SMSAero group name. +newtype Group = Group Text deriving (Eq, Show, FromJSON, ToJSON, ToHttpApiData, FromHttpApiData) + +-- | SMSAero channel name. +type ChannelName = Text + +-- | SMSAero authentication data. +data SMSAeroAuth = SMSAeroAuth + { authUser :: Text -- ^ Username. + , authPassword :: Text -- ^ MD5 hash of a password. + } + +instance FromJSON SMSAeroAuth where + parseJSON (Object o) = SMSAeroAuth + <$> o .: "user" + <*> o .: "password" + parseJSON _ = empty + +instance ToJSON SMSAeroAuth where + toJSON SMSAeroAuth{..} = object + [ "user" .= authUser + , "password" .= authPassword ] + +-- | Phone number. +newtype Phone = Phone { getPhone :: Int64 } deriving (Eq, Show, ToHttpApiData, FromHttpApiData) + +-- | Date. Textually @SMSAeroDate@ is represented as a number of seconds since 01 Jan 1970. +newtype SMSAeroDate = SMSAeroDate { getSMSAeroDate :: UTCTime } deriving (Eq, Show) + +instance ToHttpApiData SMSAeroDate where + toQueryParam (SMSAeroDate dt) = Text.pack (show (utcTimeToPOSIXSeconds dt)) + +instance FromHttpApiData SMSAeroDate where + parseQueryParam s = do + n <- fromInteger <$> parseQueryParam s + return (SMSAeroDate (posixSecondsToUTCTime n)) + +-- | Send type. This is used to describe send channel, equals to @FreeSignatureExceptMTC@ by default. +-- Textually @SendType@ is represented as a number from 1 to 6, excluding 5. +data SendType + = PaidSignature -- ^ Paid literal signature for all operators. + | FreeSignatureExceptMTC -- ^ Free literal signature for all operators except MTS. + | FreeSignature -- ^ Free literal signature for all operators. + | InfoSignature -- ^ Infosignature for all operators. + | International -- ^ International delivery (for RU and KZ operators). + deriving (Eq, Show, Bounded, Enum) + +-- | Digital send channel. Textually represented as '1' if the parameter is present. +data DigitalChannel = DigitalChannel + +instance ToHttpApiData DigitalChannel where + toQueryParam _ = "1" + +instance FromHttpApiData DigitalChannel where + parseQueryParam "1" = Right DigitalChannel + parseQueryParam x = defaultParseError x + +instance ToHttpApiData SendType where + toQueryParam PaidSignature = "1" + toQueryParam FreeSignatureExceptMTC = "2" + toQueryParam FreeSignature = "3" + toQueryParam InfoSignature = "4" + toQueryParam International = "6" + +instance FromHttpApiData SendType where + parseQueryParam = parseBoundedQueryParam + +-- | Subscriber's name. +newtype Name = Name Text deriving (Eq, Show, ToHttpApiData, FromHttpApiData) + +-- | Subscriber's birth date. Textually represented in %Y-%m-%d format. +newtype BirthDate = BirthDate Day deriving (Eq, Show, ToHttpApiData, FromHttpApiData) + diff --git a/src/SMSAero/Utils.hs b/src/SMSAero/Utils.hs deleted file mode 100644 --- a/src/SMSAero/Utils.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} --- | --- Module : SMSAero.Utils --- Copyright : (c) 2015, GetShopTV --- License : BSD3 --- Maintainer : nickolay@getshoptv.com --- Stability : experimental --- --- This module defines @'DistributiveClient'@ class --- to help distribute functions over alternatives (@':<|>'@). -module SMSAero.Utils where - -import Servant.API.Alternative - --- | Distribute a client looking like --- --- @ --- a -> (b ':<|>' ... ':<|>' c) --- @ --- --- into --- --- @ --- (a -> b) ':<|>' ... ':<|>' (a -> c) --- @ --- --- This is useful to bring authentication credentials to --- individual client endpoint queries. -class DistributiveClient client client' where - distributeClient :: client -> client' - --- | Base case. -instance DistributiveClient (a -> b) (a -> b) where - distributeClient = id - --- | Distribute function over alternative. -instance (DistributiveClient (a -> b) b', DistributiveClient (a -> c) c') => DistributiveClient (a -> (b :<|> c)) (b' :<|> c') where - distributeClient client = distributeClient (fmap left client) :<|> distributeClient (fmap right client) - where - left (l :<|> _) = l - right (_ :<|> r) = r