Select Git revision
-
Tomáš Valenta authoredTomáš Valenta authored
API.hs 9.89 KiB
-- |
-- Module : Pelican.API
-- Copyright : Jan Hamal Dvořák
-- License : AGPL-3.0-or-later
--
-- Maintainer : jan.hamal.dvorak@pirati.cz
-- Stability : unstable
-- Portability : non-portable (ghc)
--
module Pelican.API
( apiRoutes
)
where
import Praha
import Pelican.Action
import Pelican.Common
import Pelican.Model
import Pelican.Types
import Data.Aeson as Aeson
import Data.Text (splitOn)
import Data.UUID (UUID, fromText, toText)
import Data.Time.Clock
import Data.Time.Calendar.OrdinalDate
import Data.Time.Format.ISO8601
apiRoutes :: Dispatch (Action ()) ()
apiRoutes = do
route getReceiptR
route getReceiptsR
route postSendToNumberR
route postSendToContactR
newtype ParamUUID = ParamUUID UUID
instance Param ParamUUID where
fromParam = fmap ParamUUID . fromText
toParam (ParamUUID uuid) = toText uuid
pgConflict :: SqlError -> Action ()
pgConflict SqlError{..} = do
abort conflict409 [] (cs sqlErrorDetail)
postSendToNumberR :: Route '[] (Action ())
postSendToNumberR = post handle // "v1" // "send" // "to-number"
/? acceptJSON /? offerText
where
handle = do
-- Read the request. Automatically dies on parsing error.
SendToNumber{..} <- getJSON
-- Check that the application is allowed to be billed.
checkBilling BillSender application token
-- Check that the application has not yet exceeded its daily quota.
checkQuota application
case centre of
Nothing -> return ()
Just cc -> checkCostCentre cc
handlePgErrors pgConflict ["23505"] do
-- Proceed to insert the message into the history and queue. Only (historyId :: Int64) <- do
query1 [sql| insert into history (appid, payload, number, receipt,
cost_centre)
values (?, ?, ?, ?, ?) returning id |]
(application, payload, number, receipt, centre)
execute_ [sql| insert into queue (history, payload)
values (?, ?) |]
(historyId, interpolated payload interpolate)
-- Notify our sender thread.
execute_ [sql| notify send |] ()
-- We set 202 status to indicate that nothing is certain at this point.
-- The gateway may yet reject the message.
setStatus status202
sendText ""
data SendToNumber
= SendToNumber
{ number :: PhoneNumber
, payload :: Text
, interpolate :: Maybe (Vector Text)
, receipt :: Maybe UUID
, application :: Text
, token :: Text
, centre :: Maybe Text
}
deriving (Show, Generic)
instance FromJSON SendToNumber
postSendToContactR :: Route '[] (Action ())
postSendToContactR = post handle // "v1" // "send" // "to-contact"
/? acceptJSON /? offerText
where
handle = do
-- Read the request. Automatically dies on parsing error.
SendToContact{..} <- getJSON
-- Check that the application is allowed to bill in specified way.
checkBilling billing application token
-- Check that the application has not yet exceeded its daily quota.
checkQuota application
case centre of
Nothing -> return ()
Just cc -> checkCostCentre cc
-- Find the recipient.
contacts <- query [sql| select number, cost_centre from contact
where userid = ? |] (Only contact)
-- Find the contact or fail.
(number :: PhoneNumber, ccid :: Text) <-
case contacts of
[] -> abort badRequest400 [] "Contact not found."
c:_ -> return c
-- Respect specified billing method.
let centre' = case billing of
BillSender -> centre
BillRecipient -> Just ccid
handlePgErrors pgConflict ["23505"] do
-- Proceed to insert the message into the history and queue.
Only (historyId :: Int64) <- do query1 [sql| insert into history (appid, payload, number, receipt,
cost_centre, userid)
values (?, ?, ?, ?, ?, ?) returning id |]
(application, payload, number, receipt, centre', contact)
execute_ [sql| insert into queue (history, payload)
values (?, ?) |]
(historyId, interpolated payload interpolate)
-- Notify our sender thread.
execute_ [sql| notify send |] ()
-- We set 202 status to indicate that nothing is certain at this point.
-- The gateway may yet reject the message.
setStatus status202
sendText ""
data SendToContact
= SendToContact
{ contact :: Text
, payload :: Text
, interpolate :: Maybe (Vector Text)
, receipt :: Maybe UUID
, application :: Text
, token :: Text
, centre :: Maybe Text
, billing :: Bill
}
deriving (Show, Generic)
instance FromJSON SendToContact
interpolated :: Text -> Maybe (Vector Text) -> Text
interpolated txt interp =
case interp of
Nothing -> txt
Just vars -> mix chunks (toList vars)
where
mix :: [Text] -> [Text] -> Text
mix [] _ = ""
mix (t:[]) _ = t
mix (t:ts) (i:is) = t <> i <> mix ts is
mix (t:ts) [] = t <> mix ts []
chunks :: [Text]
chunks = splitOn "$$" txt
getReceiptR :: Route '[ParamUUID] (Action ())
getReceiptR = get handle // "v1" // "receipt" /: "uuid"
/? offerJSON
where
handle (ParamUUID receipt) = do
recs <- query [sql| select status :: text, ts, updated, reason
from history where receipt = ? |] (Only receipt)
case recs of
[(status, ts, updated, reason)] -> do
sendJSON do
object [ "status" .= (status :: Text)
, "ts" .= (ts :: UTCTime)
, "updated" .= (updated :: UTCTime)
, "reason" .= (reason :: Maybe Text)
]
_otherwise -> abort notFound404 [] "Receipt not found."
getReceiptsR :: Route '[] (Action ())
getReceiptsR = get handle // "v1" // "receipts" /? offerJSON
where
handle = do
-- Require basic authentication of the appid.
ensureBasicAuth \appid -> do
-- Since when to return the receipts?
since <- getParamDefaultWith iso8601ParseM "since" epoch
receipts <- query [sql| select status :: text, ts, updated, reason
from history
where appid = ?
and (updated >= ? or ts >= ?) |]
(appid, since, since)
sendJSON do
Array $ fromList [ object [ "status" .= (status :: Text)
, "ts" .= (ts :: UTCTime)
, "updated" .= (updated :: UTCTime)
, "reason" .= (reason :: Maybe Text)
]
| (status, ts, updated, reason) <- receipts
]
-- Authorization -----------------------------------------------------------
ensureBasicAuth :: (Text -> Action ()) -> Action ()
ensureBasicAuth body = do
maybeAuth <- getBasicAuth
case maybeAuth of
Nothing -> do
requestBasicAuth "Send your appid and token."
Just (appid, token) -> do
res <- checkApp appid token
if res
then body appid
else requestBasicAuth "Invalid appid or token, try again."
requestBasicAuth :: Text -> Action ()
requestBasicAuth msg = do
setStatus status401
setHeader "WWW-Authenticate" "Basic"
sendText msg
checkApp :: Text -> Text -> Action Bool
checkApp appid token = do
apps :: [Int] <- fmap (fmap fromOnly) do
query [sql| select 1 from application
where appid = ? and token = ? |] (appid, token)
if mempty == apps
then return False
else return True
checkBilling :: Bill -> Text -> Text -> Action ()
checkBilling needed appid token = do
methods' <- fmap (fmap fromOnly) do
query [sql| select billing_methods from application
where appid = ? and token = ? |] (appid, token)
when (methods' == []) do
abort unauthorized401 [] "Your application is not properly registered."
let methods = mconcat methods' :: Vector Bill
unless (needed `elem` methods) do
abort forbidden403 [] (tshow needed <> " not allowed for your app.")
checkQuota :: Text -> Action ()
checkQuota appid = do
quotas <- query [sql| select today, quota
from application_today
where appid = ? |] (Only appid)
forM_ quotas \(today :: Int, quota :: Int) -> do
when (today >= quota) do
abort tooManyRequests429 []
("Daily quota of " <> tshow quota <> " messages exceeded.")
checkCostCentre :: Text -> Action ()
checkCostCentre centre = do
n <- fromOnly <$> query1 [sql| select count(*) from cost_centre
where name = ? |] (Only centre)
unless ((n :: Int) > 0) do
abort badRequest400 [] "Invalid cost centre."
-- Misc --------------------------------------------------------------------
getParamDefaultWith :: (MonadAction m, Param a)
=> (a -> Maybe b) -> Text -> b -> m b
getParamDefaultWith c n v = fromMaybe v <$> (c =<<) <$> getParamMaybe n
epoch :: UTCTime
epoch = UTCTime (fromOrdinalDate 1970 0) 0
-- vim:set ft=haskell sw=2 ts=2 et: