smsaero 0.2 → 0.3
raw patch · 7 files changed
+207/−40 lines, 7 filesdep +lensdep +servant-docs
Dependencies added: lens, servant-docs
Files
- CHANGELOG.md +11/−3
- README.md +9/−3
- docs/api-filter.hs +9/−0
- docs/api-intro.md +7/−0
- smsaero.cabal +5/−1
- src/SMSAero/API.hs +165/−31
- src/SMSAero/Client.hs +1/−2
CHANGELOG.md view
@@ -1,8 +1,16 @@+0.3+---+* Add `MessageBody` newtype for `"text"` query parameter+* Add instances for automatic API documentation via servant-docs+* Add filter for Pandoc to generate documentation in many formats+* Fix some `ToJSON` instances to match `FromJSON`+* Add `ToJSON`/`FromJSON` instances for `SMSAeroAuth`+ 0.2 ----* structure haddock documentation-* add missing ToJSON and FromText instances+* Structure haddock documentation+* Add missing `ToJSON` and `FromText` instances 0.1.1 ------* support GHC 7.8+* Add support for GHC 7.8
README.md view
@@ -7,11 +7,17 @@ ## Documentation -The original SMSAero API documentation is available [here](http://smsaero.ru/api/description).- Library documentation is available [on Hackage](http://hackage.haskell.org/package/smsaero). -The most recent documentation is available [on GitHub pages](http://getshoptv.github.io/smsaero/docs/).+The original SMSAero API documentation (in Russian) is available [here](http://smsaero.ru/api/description).++API documentation in English can be generated using [`pandoc`](http://pandoc.org):++```+$ stack exec pandoc --filter=docs/api-filter.hs -o docs/api.md api-intro.md+```++Note that you can generate this documentation in any format that `pandoc` supports (e.g. HTML, LaTeX, Markdown, etc.). ## Usage
+ docs/api-filter.hs view
@@ -0,0 +1,9 @@+module Main where++import Servant.Docs+import Servant.Docs.Pandoc+import Data.Proxy+import SMSAero (SMSAeroAPI)++main :: IO ()+main = makeFilter (docs (Proxy :: Proxy SMSAeroAPI))
+ docs/api-intro.md view
@@ -0,0 +1,7 @@+# SMSAero API documentation++This documentation is generated automatically.++The original SMSAero API documentation (in Russian)+is [available here](http://smsaero.ru/api/description).+
smsaero.cabal view
@@ -1,5 +1,5 @@ name: smsaero-version: 0.2+version: 0.3 synopsis: SMSAero API and HTTP client based on servant library. description: Please see README.md homepage: https://github.com/GetShopTV/smsaero@@ -13,6 +13,8 @@ extra-source-files: README.md , CHANGELOG.md+ , docs/api-filter.hs+ , docs/api-intro.md cabal-version: >=1.10 library@@ -26,9 +28,11 @@ , either , servant == 0.4.* , servant-client+ , servant-docs , aeson , text , time+ , lens default-language: Haskell2010 source-repository head
src/SMSAero/API.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -32,6 +33,7 @@ SMSAeroAuth(..), Signature(..), MessageId(..),+ MessageBody(..), Phone(..), SMSAeroDate(..), -- * Responses@@ -46,7 +48,8 @@ import Data.Aeson import Data.Proxy -import Data.Time (UTCTime)+import Data.Time (UTCTime(UTCTime))+import Data.Time.Calendar (fromGregorian) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) import Data.Text (Text)@@ -58,6 +61,8 @@ import Servant.API import Servant.Client+import Servant.Docs+import Control.Lens (over, (|>)) import GHC.Generics @@ -70,6 +75,9 @@ instance FromJSON a => MimeUnrender SmsAeroJson a where mimeUnrender _ = mimeUnrender (Proxy :: Proxy JSON) +instance ToJSON a => MimeRender SmsAeroJson a where+ mimeRender _ = mimeRender (Proxy :: Proxy JSON)+ -- | Like 'QueryParam', but always required. data RequiredQueryParam (sym :: Symbol) a @@ -77,18 +85,40 @@ type Client (RequiredQueryParam sym a :> sub) = a -> Client sub clientWithRoute _ req baseurl param = clientWithRoute (Proxy :: Proxy (QueryParam sym a :> sub)) req baseurl (Just param) +instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sub) => HasDocs (RequiredQueryParam sym a :> sub) where+ docsFor _ (endpoint, action) =+ docsFor subP (endpoint, action')++ 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 (Show, FromJSON, ToJSON, ToText, FromText) -- | SMSAero sent message id. newtype MessageId = MessageId Integer deriving (Show, FromJSON, ToJSON, ToText, FromText) +-- | SMSAero message body.+newtype MessageBody = MessageBody Text deriving (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 :: Integer } deriving (Show, ToText, FromText) @@ -119,6 +149,21 @@ authUser authPassword +instance HasDocs sub => HasDocs (RequireAuth :> sub) where+ docsFor _ (endpoint, action) =+ docsFor subP (endpoint, action')++ where subP = Proxy :: Proxy sub+ userP = DocQueryParam "user"+ ["alice@example.com", "bob@example.com"]+ "SMSAero username (email) for authentication."+ Normal+ passP = DocQueryParam "password"+ ["5f4dcc3b5aa765d61d8327deb882cf99", "d8578edf8458ce06fbc5bb76a58c5ca4"]+ "MD5 hash of a password."+ Normal+ action' = over params ((|> passP) . (|> userP)) action+ -- | Implicit parameter that tells SMSAero to respond with JSON. data AnswerJson @@ -126,6 +171,16 @@ type Client (AnswerJson :> sub) = Client sub clientWithRoute _ req baseurl = clientWithRoute (Proxy :: Proxy (RequiredQueryParam "answer" Text :> sub)) req baseurl "json" +instance HasDocs sub => HasDocs (AnswerJson :> sub) where+ docsFor _ (endpoint, action) = docsFor subP (endpoint, action')+ where+ subP = Proxy :: Proxy sub+ answerP = DocQueryParam "answer"+ ["json"]+ "When present makes SMSAero REST API to respond with JSON."+ Normal+ action' = over params (|> answerP) action+ -- | Regular SMSAero GET API. type SmsAeroGet a = Get '[SmsAeroJson] (SmsAeroResponse a) @@ -140,30 +195,62 @@ -- | SMSAero API to send a message. type SendApi = RequiredQueryParam "to" Phone :>- RequiredQueryParam "text" Text :>+ RequiredQueryParam "text" MessageBody :> RequiredQueryParam "from" Signature :> QueryParam "date" SMSAeroDate :> SmsAeroGet SendResponse +instance ToParam (QueryParam "to" Phone) where+ toParam _ = DocQueryParam "to"+ ["74951234567"]+ "Recipient phone number."+ Normal++instance ToParam (QueryParam "text" MessageBody) where+ toParam _ = DocQueryParam "text"+ ["Hello, world!"]+ "Message content."+ Normal++instance ToParam (QueryParam "from" Signature) where+ toParam _ = DocQueryParam "from"+ ["My Company"]+ "Sender's signature."+ Normal++instance ToParam (QueryParam "date" SMSAeroDate) where+ toParam _ = DocQueryParam "date"+ [show (utcTimeToPOSIXSeconds (UTCTime (fromGregorian 2015 01 31) 0))]+ "Requested datetime of delivery as number of seconds since 01 Jan 1970."+ Normal+ -- | SMSAero API to check message status. type StatusApi = RequiredQueryParam "id" MessageId :> SmsAeroGet StatusResponse +instance ToParam (QueryParam "id" MessageId) where+ toParam _ = DocQueryParam "id"+ ["12345"]+ "Message ID, returned previously by SMSAero."+ Normal+ -- | Every SMSAero response is either rejected or provides some info. data SmsAeroResponse a = ResponseOK a -- ^ Some useful payload. | ResponseReject Text -- ^ Rejection reason. deriving (Show, Generic)--- | This is a generic instance and __does not match__ @FromJSON@.-instance ToJSON a => ToJSON (SmsAeroResponse a) -- | SMSAero response to a send request. data SendResponse = SendAccepted MessageId -- ^ Message accepted. | SendNoCredits -- ^ No credits to send a message. deriving (Show, Generic)--- | This is a generic instance and __does not match__ @FromJSON@.-instance ToJSON SendResponse +instance ToSample (SmsAeroResponse SendResponse) (SmsAeroResponse SendResponse) where+ toSamples _ =+ [ ("When message is sent successfully.", ResponseOK (SendAccepted (MessageId 12345)))+ , ("When SMSAero account does not have enough credit.", ResponseOK SendNoCredits)+ , ("When message sender is incorrect.", ResponseReject "incorrect sender name") ]+ -- | SMSAero response to a status request. data StatusResponse = StatusDeliverySuccess -- ^ Message is successfully delivered.@@ -172,27 +259,41 @@ | StatusSmscReject -- ^ Message rejected by SMSC. | StatusQueue -- ^ Message queued. | StatusWaitStatus -- ^ Wait for message status.- deriving (Show, Generic)--- | This is a generic instance and __does not match__ @FromJSON@.-instance ToJSON StatusResponse+ deriving (Enum, Bounded, Show, Generic) +instance ToSample (SmsAeroResponse StatusResponse) (SmsAeroResponse StatusResponse) 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.-newtype BalanceResponse = BalanceResponse Double deriving (Show, ToJSON)+newtype BalanceResponse = BalanceResponse Double deriving (Show) +instance ToSample (SmsAeroResponse BalanceResponse) (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. -- This is just a list of available signatures. newtype SendersResponse = SendersResponse [Signature] deriving (Show, FromJSON, ToJSON) +instance ToSample (SmsAeroResponse SendersResponse) (SmsAeroResponse SendersResponse) where+ toSample _ = Just (ResponseOK (SendersResponse [Signature "TEST", Signature "My Company"]))+ -- | SMSAero response to a sign request. data SignResponse = SignApproved -- ^ Signature is approved. | SignRejected -- ^ Signature is rejected. | SignPending -- ^ Signature is pending.- deriving (Show, Generic)--- | This is a generic instance and __does not match__ @FromJSON@.-instance ToJSON SignResponse+ deriving (Enum, Bounded, Show, Generic) +instance ToSample (SmsAeroResponse SignResponse) (SmsAeroResponse SignResponse) where+ toSamples _ =+ [ ("When a new signature is approved.", ResponseOK SignApproved)+ , ("When a new signature is rejected.", ResponseOK SignRejected) ]+ instance FromJSON a => FromJSON (SmsAeroResponse a) where parseJSON (Object o) = do result :: Maybe Text <- o .:? "result"@@ -201,6 +302,12 @@ _ -> ResponseOK <$> parseJSON (Object o) parseJSON j = ResponseOK <$> parseJSON j +instance ToJSON a => ToJSON (SmsAeroResponse a) where+ toJSON (ResponseOK x) = toJSON x+ toJSON (ResponseReject reason) = object+ [ "result" .= ("reject" :: Text)+ , "reason" .= reason ]+ instance FromJSON SendResponse where parseJSON (Object o) = do result :: Text <- o .: "result"@@ -210,33 +317,60 @@ _ -> empty parseJSON _ = empty +instance ToJSON SendResponse where+ toJSON (SendAccepted n) = object+ [ "result" .= ("accepted" :: Text)+ , "id" .= toJSON n ]+ 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 StatusResponse where+ fromText = boundedFromText++instance ToText StatusResponse 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 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+ maybe empty pure (fromText result) parseJSON _ = empty +instance ToJSON StatusResponse where+ toJSON status = object [ "result" .= toText status ]+ instance FromJSON BalanceResponse where- parseJSON (Object o) = do- balance <- o .: "balance"- case readMaybe balance of- Just x -> pure (BalanceResponse x)- Nothing -> empty+ parseJSON (Object o) = BalanceResponse <$> o .: "balance" parseJSON _ = empty +instance ToJSON BalanceResponse where+ toJSON (BalanceResponse n) = object [ "balance" .= n ]++instance ToText SignResponse where+ toText SignApproved = "approved"+ toText SignRejected = "rejected"+ toText SignPending = "pending"++instance FromText SignResponse where+ fromText = boundedFromText+ 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+ maybe empty pure (fromText accepted) parseJSON _ = empty++instance ToJSON SignResponse where+ toJSON s = object [ "accepted" .= toText s ]
src/SMSAero/Client.hs view
@@ -11,7 +11,6 @@ import Control.Monad.Trans.Either import Data.Proxy-import Data.Text (Text) import Servant.API import Servant.Client@@ -29,7 +28,7 @@ type SmsAero a = EitherT ServantError IO (SmsAeroResponse a) -- | Send a message.-smsAeroSend :: SMSAeroAuth -> Phone -> Text -> Signature -> Maybe SMSAeroDate -> SmsAero SendResponse+smsAeroSend :: SMSAeroAuth -> Phone -> MessageBody -> Signature -> Maybe SMSAeroDate -> SmsAero SendResponse -- | Check status of a previously sent message. smsAeroStatus :: SMSAeroAuth -> MessageId -> SmsAero StatusResponse -- | Check balance.