diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +0.1.0.0 +======= + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Anton Gushcha (c) 2016 + +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 Anton Gushcha nor the names of other + 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 +OWNER 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,38 @@ +# servant-smsc-ru + +[![Build Status](https://travis-ci.org/NCrashed/servant-smsc-ru.svg?branch=master)](https://travis-ci.org/NCrashed/servant-smsc-ru) + +These are bindings to https://smsc.ru service for sending SMS/MMS message to cell phones. + +# How to use + +The general API is provided by `genericSmsSend` function, but it is too overengineered to be used +as is. Thats why several simplified wrappers are presented. + +First, you need to provide `SmscConfig` value: + +``` haskell +cfg <- defaultSmscConfig +let testSmscConfig = cfg { + smscLogin = "mylogin" + , smscPassword = "mypass" + } +``` + +After that you can send a SMS: + +``` haskell +res <- simpleSmsSend testSmscConfig testPhone "Test message" +case res of + Left er -> printLn $ "message sending: " ++ show er + Right _ -> return () +``` + +Or check how much it would cost to you: + +``` haskell +res <- getSimpleSmsCost testSmscConfig testPhone "Test message" +case res of + Left er -> assertFailure $ "message costing: " <> show er + Right v -> putStrLn $ "message cost: " <> show v +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-smsc-ru.cabal b/servant-smsc-ru.cabal new file mode 100644 --- /dev/null +++ b/servant-smsc-ru.cabal @@ -0,0 +1,72 @@ +name: servant-smsc-ru +version: 0.1.0.0 +synopsis: Servant client for smsc.ru service for sending SMS to cell phones +description: Please see README.md +homepage: https://github.com/NCrashed/servant-smsc-ru#readme +license: BSD3 +license-file: LICENSE +author: Anton Gushcha +maintainer: ncrashed@gmail.com +copyright: 2016 Anton Gushcha +category: Web +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: + Servant.API.SMSC.RU + Servant.API.SMSC.RU.API + + build-depends: + base >= 4.7 && < 5 + , aeson >= 0.11 && < 0.12 + , bytestring >= 0.10 && < 0.11 + , http-client >= 0.4 && < 0.6 + , http-client-tls >= 0.2 && < 0.4 + , mtl >= 2.2 && < 2.3 + , scientific >= 0.3 && < 0.4 + , servant >= 0.7 && < 0.9 + , servant-client >= 0.7 && < 0.9 + , text >= 1.2 && < 2 + , transformers >= 0.4 && < 0.6 + + default-language: Haskell2010 + default-extensions: + DataKinds + DeriveGeneric + FlexibleInstances + GeneralizedNewtypeDeriving + KindSignatures + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + TypeFamilies + TypeOperators + TypeSynonymInstances + +test-suite test-servant-smsc-ru + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base + , aeson + , HUnit >= 1.3 + , QuickCheck >= 2.8.2 + , quickcheck-text + , servant-smsc-ru + , tasty >= 0.11 + , tasty-hunit >= 0.9 + , tasty-quickcheck >= 0.8 + , text + , bytestring + +source-repository head + type: git + location: https://github.com/NCrashed/servant-smsc-ru diff --git a/src/Servant/API/SMSC/RU.hs b/src/Servant/API/SMSC/RU.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/SMSC/RU.hs @@ -0,0 +1,243 @@ +{-| +Module : Servant.API.SMSC.RU +Description : Meta module that contains all API for smsc.ru service +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable + +The module contains general and simplified functions to call service +for sending SMS/MMS messages. + +The general API is provided by 'genericSmsSend' function, but it is too overengineered to be used +as is. Thats why several simplified wrappers are presented. + +First, you need to provide 'SmscConfig' value: + +@ +cfg <- defaultSmscConfig +let testSmscConfig = cfg { + smscLogin = "mylogin" + , smscPassword = "mypass" + } +@ + +After that you can send a SMS: + +@ +res <- simpleSmsSend testSmscConfig testPhone "Test message" +case res of + Left er -> printLn $ "message sending: " ++ show er + Right _ -> return () +@ + +Or check how much it would cost to you: + +@ +res <- getSimpleSmsCost testSmscConfig testPhone "Test message" +case res of + Left er -> assertFailure $ "message costing: " <> show er + Right v -> putStrLn $ "message cost: " <> show v +@ + +-} +module Servant.API.SMSC.RU( + -- * API + SMSCAPI + -- ** Endpoints + , SendResponse(..) + , PhoneResp(..) + , SendEndpoint + -- * Client + , genericSmsSend + -- ** Simplified + , SmscConfig(..) + , defaultSmscConfig + , simpleSmsSend + , getSimpleSmsCost + ) where + +import Control.Monad.Except +import Data.ByteString.Lazy (ByteString) +import Data.Monoid +import Data.Proxy +import Data.Text +import GHC.Generics +import Network.HTTP.Client (Manager, newManager) +import Network.HTTP.Client.TLS +import Servant.API.SMSC.RU.API +import Servant.Client + +import qualified Data.Text as T + +-- | The most generic call to the send endpoint +genericSmsSend :: + Maybe Text -- ^ login + -> Maybe Text -- ^ psw + -> Maybe Text -- ^ phones + -> Maybe Text -- ^ mes + -> Maybe Text -- ^ id + -> Maybe Text -- ^ sender + -> Maybe Text -- ^ translit + -> Maybe Text -- ^ tinyurl + -> Maybe Text -- ^ time + -> Maybe Text -- ^ tz + -> Maybe Double -- ^ period + -> Maybe Word -- ^ freq + -> Maybe Word -- ^ flash + -> Maybe Text -- ^ bin + -> Maybe Word -- ^ push + -> Maybe Word -- ^ hlr + -> Maybe Word -- ^ ping + -> Maybe Word -- ^ mms + -> Maybe Word -- ^ mail + -> Maybe Word -- ^ call + -> Maybe Text -- ^ voice + -> Maybe Text -- ^ param + -> Maybe Text -- ^ subj + -> Maybe Text -- ^ charset + -> Maybe Word -- ^ cost + -> Maybe Word -- ^ fmt, should be always 3 + -> Maybe Text -- ^ list + -> Maybe Text -- ^ valid + -> Maybe Word -- ^ maxsms + -> Maybe Text -- ^ imgcode + -> Maybe Text -- ^ userip + -> Maybe Word -- ^ err + -> Maybe Word -- ^ op + -> Maybe Text -- ^ pp + -> ByteString -- ^ Request body (voice messages and etc) + -> Manager -> BaseUrl -> ClientM SendResponse +genericSmsSend = client (Proxy :: Proxy SMSCAPI) + +-- | Required common info for smsc API +data SmscConfig = SmscConfig { + smscLogin :: !Text -- ^ Account login +, smscPassword :: !Text -- ^ Account password +, smscManager :: !Manager -- ^ Connection manager (use http-) +, smscBaseUrl :: !BaseUrl +} deriving (Generic) + +instance Show SmscConfig where + show SmscConfig{..} = "SmscConfig {" + <> "smscLogin = " <> show smscLogin + <> ", smscPassword = " <> show smscPassword + <> ", smscManager = " + <> ", smscBaseUrl = " <> show smscBaseUrl + <> " }" + +defaultSmscConfig :: MonadIO m => m SmscConfig +defaultSmscConfig = do + mng <- liftIO $ newManager tlsManagerSettings + return SmscConfig { + smscLogin = "" + , smscPassword = "" + , smscManager = mng + , smscBaseUrl = BaseUrl { + baseUrlScheme = Https + , baseUrlHost = "smsc.ru" + , baseUrlPort = 443 + , baseUrlPath = "" + } + } + +-- | Simple send message to given phone +simpleSmsSend :: MonadIO m + => SmscConfig -- ^ Authorisation and other general config + -> Text -- ^ Phone + -> Text -- ^ Message + -> m (Either Text SendResponse) +simpleSmsSend SmscConfig{..} phone msg = do + res <- liftIO . runExceptT $ genericSmsSend + (Just smscLogin) + (Just smscPassword) + (Just phone) -- phones + (Just msg) -- mes + Nothing -- id + Nothing -- sender + Nothing -- translit + Nothing -- tinyurl + Nothing -- time + Nothing -- tz + Nothing -- period + Nothing -- freq + Nothing -- flash + Nothing -- bin + Nothing -- push + Nothing -- hlr + Nothing -- ping + Nothing -- mms + Nothing -- mail + Nothing -- call + Nothing -- voice + Nothing -- param + Nothing -- subj + Nothing -- charset + Nothing -- cost + (Just 3) -- fmt always 3 + Nothing -- list + Nothing -- valid + Nothing -- maxsms + Nothing -- imgcode + Nothing -- userip + Nothing -- err + Nothing -- op + Nothing -- pp + mempty + smscManager smscBaseUrl + return $ case res of + Left e -> Left (T.pack $ show e) + Right r -> Right r + +-- | Getting cost of message without sending +getSimpleSmsCost :: MonadIO m + => SmscConfig -- ^ Authorisation and other general config + -> Text -- ^ Phone + -> Text -- ^ Message + -> m (Either Text Text) +getSimpleSmsCost SmscConfig{..} phone msg = do + res <- liftIO . runExceptT $ genericSmsSend + (Just smscLogin) + (Just smscPassword) + (Just phone) -- phones + (Just msg) -- mes + Nothing -- id + Nothing -- sender + Nothing -- translit + Nothing -- tinyurl + Nothing -- time + Nothing -- tz + Nothing -- period + Nothing -- freq + Nothing -- flash + Nothing -- bin + Nothing -- push + Nothing -- hlr + Nothing -- ping + Nothing -- mms + Nothing -- mail + Nothing -- call + Nothing -- voice + Nothing -- param + Nothing -- subj + Nothing -- charset + (Just 1) -- cost + (Just 3) -- fmt always 3 + Nothing -- list + Nothing -- valid + Nothing -- maxsms + Nothing -- imgcode + Nothing -- userip + Nothing -- err + Nothing -- op + Nothing -- pp + mempty + smscManager smscBaseUrl + return $ case res of + Left e -> Left (T.pack $ show e) + Right r -> case r of + se@SendError{} -> Left (T.pack $ show se) + SendSuccess{..} -> case sendSuccCost of + Nothing -> Left "No cost in response" + Just c -> return c diff --git a/src/Servant/API/SMSC/RU/API.hs b/src/Servant/API/SMSC/RU/API.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/SMSC/RU/API.hs @@ -0,0 +1,156 @@ +{-| +Module : Servant.API.SMSC.RU.API +Description : Contains raw servant API for smsc.ru service +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable +-} +module Servant.API.SMSC.RU.API( + -- * API + SMSCAPI + -- ** Endpoints + , SendResponse(..) + , PhoneResp(..) + , SendErrorCode(..) + , SendEndpoint + ) where + +import Control.Monad +import Data.Aeson +import Data.Monoid +import Data.Scientific +import Data.Text +import GHC.Generics +import Servant.API + +import Data.ByteString.Lazy (ByteString) + +-- | All supported API of smsc.ru service +type SMSCAPI = SendEndpoint + +-- | Error type +data SendErrorCode = + SendParametersError + | SendInvalidLoginPass + | SendLowFunds + | SendBlockedDueErrors + | SendInvalidDateFormat + | SendForbiddenMessage + | SendInvalidPhoneFormat + | SendMessageCannotBeDelivered + | SendTooMuchMessages + deriving (Generic, Show, Eq, Bounded, Enum) + +-- | Convert from received error code +fromErrorCode :: Word -> Maybe SendErrorCode +fromErrorCode w = case w of + 1 -> Just SendParametersError + 2 -> Just SendInvalidLoginPass + 3 -> Just SendLowFunds + 4 -> Just SendBlockedDueErrors + 5 -> Just SendInvalidDateFormat + 6 -> Just SendForbiddenMessage + 7 -> Just SendInvalidPhoneFormat + 8 -> Just SendMessageCannotBeDelivered + 9 -> Just SendTooMuchMessages + _ -> Nothing + +instance FromJSON SendErrorCode where + parseJSON (Number s) = case fromErrorCode =<< toBoundedInteger s of + Nothing -> fail $ "unknown error code " <> show s + Just c -> return c + parseJSON _ = mzero + +-- | Additional info about phone number +data PhoneResp = PhoneResp { + phoneNumber :: !Text +, phoneMccmnc :: !Text +, phoneCost :: !Text +, phoneStatus :: !Text +, phoneError :: !Text +} deriving (Generic, Show) + +instance FromJSON PhoneResp where + parseJSON (Object o) = PhoneResp + <$> o .: "phone" + <*> o .: "mccmnc" + <*> o .: "cost" + <*> o .: "status" + <*> o .: "error" + parseJSON _ = mzero + +-- | Response for 'SendEndpoint' +data SendResponse = + -- | Server returned error payload + SendError { + sendError :: !Text -- ^ Desciption of error + , sendErrorCode :: !SendErrorCode -- ^ Error code + , sendErrorId :: !(Maybe Text) -- ^ ID of failed message + } + -- | Server retunred success payload + | SendSuccess { + sendSuccId :: !(Maybe Word) -- ^ ID of sended message + , sendSuccCnt :: !Word -- ^ Count of messages sended (huge payloads are splitted) + , sendSuccCost :: !(Maybe Text) -- ^ Cost of sending + , sendSuccBalance :: !(Maybe Text) -- ^ Funds of the account left after the call + , sendSuccPhones :: !(Maybe [PhoneResp]) -- ^ Additional info by phone number + } + deriving (Generic, Show) + +instance FromJSON SendResponse where + parseJSON (Object o) = do + merr <- o .:? "error" + case merr of + Nothing -> SendSuccess + <$> o .:? "id" + <*> o .: "cnt" + <*> o .:? "cost" + <*> o .:? "balance" + <*> o .:? "phones" + Just err -> SendError err + <$> o .: "error_code" + <*> o .:? "id" + parseJSON _ = mzero + +-- | Endpoint for sending sms, this is low-level most general +-- API that is used to built small helper functions. +type SendEndpoint = "sys" :> "send.php" + :> QueryParam "login" Text + :> QueryParam "psw" Text + :> QueryParam "phones" Text + :> QueryParam "mes" Text + -- additional parameters + :> QueryParam "id" Text + :> QueryParam "sender" Text + :> QueryParam "translit" Text + :> QueryParam "tinyurl" Text + :> QueryParam "time" Text + :> QueryParam "tz" Text + :> QueryParam "period" Double + :> QueryParam "freq" Word + :> QueryParam "flash" Word + :> QueryParam "bin" Text + :> QueryParam "push" Word + :> QueryParam "hlr" Word + :> QueryParam "ping" Word + :> QueryParam "mms" Word + :> QueryParam "mail" Word + :> QueryParam "call" Word + :> QueryParam "voice" Text + :> QueryParam "param" Text + :> QueryParam "subj" Text + :> QueryParam "charset" Text + :> QueryParam "cost" Word + :> QueryParam "fmt" Word -- should be always 3 + :> QueryParam "list" Text + :> QueryParam "valid" Text + :> QueryParam "maxsms" Word + :> QueryParam "imgcode" Text + :> QueryParam "userip" Text + :> QueryParam "err" Word + :> QueryParam "op" Word + :> QueryParam "pp" Text + :> ReqBody '[OctetStream] ByteString + :> Post '[JSON] SendResponse diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +module Main where + +import Control.Monad +import Data.Aeson +import Data.Either +import Data.Maybe +import Data.Monoid +import Data.Text +import System.IO.Unsafe +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC + +import qualified Data.ByteString.Lazy as BS + +import Servant.API.SMSC.RU + +data TestConfig = TestConfig Text Text Text + +instance FromJSON TestConfig where + parseJSON (Object o) = TestConfig + <$> o .: "login" + <*> o .: "password" + <*> o .: "phone" + parseJSON _ = mzero + +testConfig :: TestConfig +testConfig = fromJust $ decode' $ unsafePerformIO (BS.readFile "smsc.test.json") + +-- | Load config from file +testSmscConfig :: SmscConfig +testSmscConfig = (unsafePerformIO defaultSmscConfig) { + smscLogin = login + , smscPassword = pass + } + where + TestConfig login pass _ = testConfig + +-- | Phone number we test with +testPhone :: Text +testPhone = let TestConfig _ _ phone = testConfig in phone + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [qcProperties, unitTests] + +qcProperties :: TestTree +qcProperties = testGroup "Properties" [ + testCase "Simple send" $ do + res <- simpleSmsSend testSmscConfig testPhone "Test message" + case res of + Left er -> assertFailure $ "message sending: " <> show er + Right _ -> return () + , testCase "Simple cost" $ do + res <- getSimpleSmsCost testSmscConfig testPhone "Test message" + case res of + Left er -> assertFailure $ "message costing: " <> show er + Right v -> putStrLn $ "message cost: " <> show v + ] + +unitTests :: TestTree +unitTests = testGroup "Unit tests" [ + + ]