smsaero (empty) → 0.1

raw patch · 8 files changed

+360/−0 lines, 8 filesdep +aesondep +basedep +eithersetup-changed

Dependencies added: aeson, base, either, servant, servant-client, text, time

Files

• LICENSE +28/−0
• README.md +24/−0
• Setup.hs +2/−0
• smsaero.cabal +34/−0
• src/SMSAero.hs +7/−0
• src/SMSAero/API.hs +194/−0
• src/SMSAero/Client.hs +38/−0
• src/SMSAero/Utils.hs +33/−0

@@ -0,0 +1,28 @@+Copyright (c) 2015, GetShopTV+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of smsaero nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+

@@ -0,0 +1,24 @@+# smsaero++[![Build Status](https://travis-ci.org/GetShopTV/smsaero.svg?branch=master)](https://travis-ci.org/GetShopTV/smsaero)++SMSAero API and HTTP client based on servant library.++## Usage++Import `SMSAero` and `Control.Monad.Trans.Either` module to interact with SMSAero:++```+>>> :s -XOverloadedStrings+>>> import SMSAero+>>> import Control.Monad.Trans.Either+>>> let credentials = SMSAeroAuth "user@example.com" "md5-password-hash"+>>> runEitherT $ smsAeroBalance credentials+Right (ResponseOK (BalanceResponse 10.0))+```++## Contributing++Contributions and bug reports are welcome!++*GetShopTV Team*

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,34 @@+name:                smsaero+version:             0.1+synopsis:            SMSAero API and HTTP client based on servant library.+description:         Please see README.md+homepage:            https://github.com/GetShopTV/smsaero+license:             BSD3+license-file:        LICENSE+author:              Nickolay Kudasov+maintainer:          nickolay@getshoptv.com+-- copyright:           +category:            Web+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:+    SMSAero+    SMSAero.API+    SMSAero.Client+    SMSAero.Utils+  build-depends:       base >= 4.7 && < 5+                     , either+                     , servant        == 0.4.*+                     , servant-client+                     , aeson+                     , text+                     , time+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/GetShopTV/smsaero.git

@@ -0,0 +1,7 @@+module SMSAero (+  module SMSAero.API,+  module SMSAero.Client+) where++import SMSAero.API+import SMSAero.Client

@@ -0,0 +1,194 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module SMSAero.API where++import Data.Aeson+import Data.Proxy++import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)++import Data.Text (Text)+import qualified Data.Text as Text++import Control.Applicative+import GHC.TypeLits (Symbol, KnownSymbol)+import Text.Read (readMaybe)++import Servant.API+import Servant.Client++-- | Content type for SMSAero JSON answer (it has JSON body but "text/plain" Content-Type).+data SmsAeroJson++instance Accept SmsAeroJson where+  contentType _ = contentType (Proxy :: Proxy PlainText)++instance FromJSON a => MimeUnrender SmsAeroJson a where+  mimeUnrender _ = mimeUnrender (Proxy :: Proxy JSON)++-- | Like 'QueryParam', but always required.+data RequiredQueryParam (sym :: Symbol) a++instance (HasClient sub, KnownSymbol sym, ToText 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)++-- | SMSAero sender's signature. This is used for the "from" field.+newtype Signature = Signature { getSignature :: Text } deriving (Show, FromJSON, ToText)++-- | SMSAero sent message id.+newtype MessageId = MessageId Integer deriving (Show, FromJSON, ToText)++-- | SMSAero authentication data.+data SMSAeroAuth = SMSAeroAuth+  { authUser      :: Text   -- ^ Username.+  , authPassword  :: Text   -- ^ MD5 hash of a password.+  }++-- | Phone number.+newtype Phone = Phone { getPhone :: Integer } deriving (Show, ToText)++-- | Date.+newtype SMSAeroDate = SMSAeroDate { getSMSAeroDate :: UTCTime } deriving (Show)++instance ToText SMSAeroDate where+  toText (SMSAeroDate dt) = Text.pack (show (utcTimeToPOSIXSeconds dt))++-- | SMSAero authentication credentials.+data RequireAuth++instance HasClient sub => HasClient (RequireAuth :> sub) where+  type Client (RequireAuth :> sub) = SMSAeroAuth -> Client sub++  clientWithRoute _ req baseurl SMSAeroAuth{..} =+    clientWithRoute+      (Proxy :: Proxy (RequiredQueryParam "user"     Text :>+                       RequiredQueryParam "password" Text :>+                       sub))+      req+      baseurl+      authUser+      authPassword++-- | 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"++-- | 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)++-- | SMSAero API to send a message.+type SendApi =+  RequiredQueryParam "to"   Phone       :>+  RequiredQueryParam "text" Text        :>+  RequiredQueryParam "from" Signature   :>+  QueryParam "date" SMSAeroDate :>+  SmsAeroGet SendResponse++-- | SMSAero API to check message status.+type StatusApi = RequiredQueryParam "id" MessageId :> SmsAeroGet StatusResponse++-- | Every SMSAero response is either rejected or provides some info.+data SmsAeroResponse a+  = ResponseOK a        -- ^ Some useful payload.+  | ResponseReject Text -- ^ Rejection reason.+  deriving (Show)++-- | SMSAero response to a send request.+data SendResponse+  = SendAccepted MessageId  -- ^ Message accepted.+  | SendNoCredits           -- ^ No credits to send a message.+  deriving (Show)++-- | SMSAero response to a status request.+data StatusResponse+  = StatusDeliverySuccess   -- ^ Message is successfully delivered.+  | StatusDeliveryFailure   -- ^ Message delivery has failed.+  | StatusSmscSubmit        -- ^ Message submitted to SMSC.+  | StatusSmscReject        -- ^ Message rejected by SMSC.+  | StatusQueue             -- ^ Message queued.+  | StatusWaitStatus        -- ^ Wait for message status.+  deriving (Show)++-- | SMSAero response to a balance request.+-- This is a number of available messages to send.+newtype BalanceResponse = BalanceResponse Double deriving (Show)++-- | SMSAero response to a senders request.+-- This is just a list of available signatures.+newtype SendersResponse = SendersResponse [Signature] deriving (Show, FromJSON)++-- | SMSAero response to a sign request.+data SignResponse+  = SignApproved  -- ^ Signature is approved.+  | SignRejected  -- ^ Signature is rejected.+  | SignPending   -- ^ Signature is pending.+  deriving (Show)++instance FromJSON a => FromJSON (SmsAeroResponse a) where+  parseJSON (Object o) = do+    result :: Maybe Text <- o .:? "result"+    case result of+      Just "reject" -> ResponseReject <$> o .: "reason"+      _ -> ResponseOK <$> parseJSON (Object o)+  parseJSON json = ResponseOK <$> parseJSON json++instance FromJSON SendResponse where+  parseJSON (Object o) = do+    result :: Text <- o .: "result"+    case result of+      "accepted"    -> SendAccepted <$> o .: "id"+      "no credits"  -> pure SendNoCredits+      _ -> empty+  parseJSON _ = empty++instance FromJSON StatusResponse where+  parseJSON (Object o) = do+    result :: Text <- o .: "result"+    case result of+      "delivery success"  -> pure StatusDeliverySuccess+      "delivery failure"  -> pure StatusDeliveryFailure+      "smsc submit"       -> pure StatusSmscSubmit+      "smsc reject"       -> pure StatusSmscReject+      "queue"             -> pure StatusQueue+      "wait status"       -> pure StatusWaitStatus+      _ -> empty+  parseJSON _ = empty++instance FromJSON BalanceResponse where+  parseJSON (Object o) = do+    balance <- o .: "balance"+    case readMaybe balance of+      Just x  -> pure (BalanceResponse x)+      Nothing -> empty+  parseJSON _ = empty++instance FromJSON SignResponse where+  parseJSON (Object o) = do+    accepted :: Text <- o .: "accepted"+    case accepted of+      "approved" -> pure SignApproved+      "rejected" -> pure SignRejected+      "pending"  -> pure SignPending+      _ -> empty+  parseJSON _ = empty

@@ -0,0 +1,38 @@+module SMSAero.Client where++import Control.Monad.Trans.Either++import Data.Proxy+import Data.Text (Text)++import Servant.API+import Servant.Client++import SMSAero.API+import SMSAero.Utils++-- | SMSAero client.+smsAeroClient :: Client SMSAeroAPI+smsAeroClient = client (Proxy :: Proxy SMSAeroAPI) host+  where+    host = BaseUrl Https "gate.smsaero.ru" 443++-- | Common SMSAero client type.+type SmsAero a = EitherT ServantError IO (SmsAeroResponse a)++-- | Send a message.+smsAeroSend    :: SMSAeroAuth -> Phone -> Text -> Signature -> Maybe SMSAeroDate -> SmsAero SendResponse+-- | Check status of a previously sent message.+smsAeroStatus  :: SMSAeroAuth -> MessageId -> SmsAero StatusResponse+-- | Check balance.+smsAeroBalance :: SMSAeroAuth -> SmsAero BalanceResponse+-- | Check the list of available sender signatures.+smsAeroSenders :: SMSAeroAuth -> SmsAero SendersResponse+-- | Acquire a new signature.+smsAeroSign    :: SMSAeroAuth -> SmsAero SignResponse+(smsAeroSend    :<|>+ smsAeroStatus  :<|>+ smsAeroBalance :<|>+ smsAeroSenders :<|>+ smsAeroSign) = distributeClient smsAeroClient+

@@ -0,0 +1,33 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+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'++instance DistributiveClient (a -> b) (a -> b) where+  distributeClient = id++instance (DistributiveClient (a -> b) b', DistributiveClient (a -> c) c') => DistributiveClient (a -> (b :<|> c)) (b' :<|> c') where+  distributeClient client = distributeClient (aleft <$> client) :<|> distributeClient (aright <$> client)+    where+      aleft  (l :<|> _) = l+      aright (_ :<|> r) = r