module SMSAero.API (
SMSAeroAPI,
SendApi,
StatusApi,
SmsAeroJson,
AnswerJson,
RequireAuth,
RequiredQueryParam,
SmsAeroGet,
SMSAeroAuth(..),
Signature(..),
MessageId(..),
MessageBody(..),
Phone(..),
SMSAeroDate(..),
SmsAeroResponse(..),
SendResponse(..),
StatusResponse(..),
BalanceResponse(..),
SendersResponse(..),
SignResponse(..),
) where
import Data.Aeson
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 Control.Applicative
import GHC.TypeLits (Symbol, KnownSymbol)
import Text.Read (readMaybe)
import Servant.API
import Servant.Client
import Servant.Docs
import Control.Lens (over, (|>))
import GHC.Generics
data SmsAeroJson
instance Accept SmsAeroJson where
contentType _ = contentType (Proxy :: Proxy PlainText)
instance FromJSON a => MimeUnrender SmsAeroJson a where
mimeUnrender _ = mimeUnrender (Proxy :: Proxy JSON)
instance ToJSON a => MimeRender SmsAeroJson a where
mimeRender _ = mimeRender (Proxy :: Proxy JSON)
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)
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
newtype Signature = Signature { getSignature :: Text } deriving (Show, FromJSON, ToJSON, ToText, FromText)
newtype MessageId = MessageId Integer deriving (Show, FromJSON, ToJSON, ToText, FromText)
newtype MessageBody = MessageBody Text deriving (Show, FromJSON, ToJSON, ToText, FromText)
data SMSAeroAuth = SMSAeroAuth
{ authUser :: Text
, authPassword :: Text
}
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 ]
newtype Phone = Phone { getPhone :: Integer } deriving (Show, ToText, FromText)
newtype SMSAeroDate = SMSAeroDate { getSMSAeroDate :: UTCTime } deriving (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))
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
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
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"
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
type SmsAeroGet a = Get '[SmsAeroJson] (SmsAeroResponse a)
type SMSAeroAPI = RequireAuth :> AnswerJson :>
("send" :> SendApi
:<|> "status" :> StatusApi
:<|> "balance" :> SmsAeroGet BalanceResponse
:<|> "senders" :> SmsAeroGet SendersResponse
:<|> "sign" :> SmsAeroGet SignResponse)
type SendApi =
RequiredQueryParam "to" Phone :>
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
type StatusApi = RequiredQueryParam "id" MessageId :> SmsAeroGet StatusResponse
instance ToParam (QueryParam "id" MessageId) where
toParam _ = DocQueryParam "id"
["12345"]
"Message ID, returned previously by SMSAero."
Normal
data SmsAeroResponse a
= ResponseOK a
| ResponseReject Text
deriving (Show, Generic)
data SendResponse
= SendAccepted MessageId
| SendNoCredits
deriving (Show, Generic)
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") ]
data StatusResponse
= StatusDeliverySuccess
| StatusDeliveryFailure
| StatusSmscSubmit
| StatusSmscReject
| StatusQueue
| StatusWaitStatus
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) ]
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") ]
newtype SendersResponse = SendersResponse [Signature] deriving (Show, FromJSON, ToJSON)
instance ToSample (SmsAeroResponse SendersResponse) (SmsAeroResponse SendersResponse) where
toSample _ = Just (ResponseOK (SendersResponse [Signature "TEST", Signature "My Company"]))
data SignResponse
= SignApproved
| SignRejected
| SignPending
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"
case result of
Just "reject" -> ResponseReject <$> o .: "reason"
_ -> 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"
case result of
"accepted" -> SendAccepted <$> o .: "id"
"no credits" -> pure SendNoCredits
_ -> empty
parseJSON _ = empty
instance ToJSON SendResponse where
toJSON (SendAccepted n) = object
[ "result" .= ("accepted" :: Text)
, "id" .= toJSON n ]
toJSON SendNoCredits = object
[ "result" .= ("no credits" :: Text)]
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"
maybe empty pure (fromText result)
parseJSON _ = empty
instance ToJSON StatusResponse where
toJSON status = object [ "result" .= toText status ]
instance FromJSON BalanceResponse where
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"
maybe empty pure (fromText accepted)
parseJSON _ = empty
instance ToJSON SignResponse where
toJSON s = object [ "accepted" .= toText s ]