diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/docs/api-filter.hs b/docs/api-filter.hs new file mode 100644 --- /dev/null +++ b/docs/api-filter.hs @@ -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)) diff --git a/docs/api-intro.md b/docs/api-intro.md new file mode 100644 --- /dev/null +++ b/docs/api-intro.md @@ -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). + diff --git a/smsaero.cabal b/smsaero.cabal --- a/smsaero.cabal +++ b/smsaero.cabal @@ -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 diff --git a/src/SMSAero/API.hs b/src/SMSAero/API.hs --- a/src/SMSAero/API.hs +++ b/src/SMSAero/API.hs @@ -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 ] diff --git a/src/SMSAero/Client.hs b/src/SMSAero/Client.hs --- a/src/SMSAero/Client.hs +++ b/src/SMSAero/Client.hs @@ -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.