Implement contact database

Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>

README.md

@@ -107,6 +107,35 @@ V historii zpráv tak v příkladu výše zůstane pouze text _"Váš PIN je $$.
 - V případě chyby je kód odpovědi z řad 400 nebo 500 a tělo obsahuje vysvětlení. U chyb na straně klienta (400) je tělo zpravidla typu `text/plain` a obsahuje krátký popis problému.
 
 
+### Odeslání SMS zprávy kontaktu
+
+```http
+POST /v1/send/to-contact HTTP/1.1
+Content-Type: application/json
+
+{
+    "application": "přidělené <appid>",
+    "token": "přidělený přístupový <token>",
+    "contact": "<název> kontaktu",
+    "payload": "Váš PIN je $$. Piráti",
+    "interpolate": ["1234"],
+    "receipt": "volitelné <uuid> pro kontrolu doručení",
+    "centre": "volitelný <název> nákladového střediska",
+    "billing": "bill-sender|bill-recipient"
+}
+```
+
+```http
+HTTP/1.1 202 Accepted
+Content-Type: text/plain; charset=utf8
+```
+
+Funguje obdobně jako `/v1/send/to-number` s následujícími rozdíly:
+
+- Namísto číslo příjemce se použije název kontaktu. Například `uid:jan.hamal.dvorak`, `forum:410` nebo `sso:b503b712-9f7c-4479-a1dd-e7b6447dc2cb`. Záleží jaké kontakty jsou v DB definovány.
+- Je nutné uvést pole `billing`; hodnota `bill-sender` účtuje zprávu na vrub nákladového střediska uvedeného v poli `centre` (které je možné vynechat pro výchozí účtování na vrub aplikace); naopak `bill-recipient` účtuje zprávu na vrub nákladového střediska příjemce.
+
+
 ### Kontrola doručenky
 
 ```http

sql/013-contacts.sql

+-- In order to be able to reach people without necessary knowing their
+-- numbers and to be able to bill recipient cost centre, create an
+-- address book of sorts.
+
+create table contact (
+	-- Boring primary key.
+	id bigserial not null primary key,
+
+	-- Arbitrary user identifier string for the API.
+	userid varchar not null,
+
+	-- Phone number of the contact for the Sender.
+	number varchar not null,
+
+	-- Cost centre of the user for billing.
+	cost_centre varchar not null collate "und-x-icu",
+
+	-- Replication & other metadata.
+	meta jsonb not null default '{}',
+
+	-- User identifiers are unique, but numbers can repeat.
+	unique(userid)
+);
+
+-- Make sure we don't point outside of the cost_centre table.
+alter table contact add constraint contact_cost_centre_fkey
+	foreign key (cost_centre)
+		references cost_centre (name)
+		on delete restrict
+		on update cascade;
+
+-- Speed up some metadata-based searches.
+create index contact_meta_idx on contact
+	using gin (meta jsonb_path_ops);
+
+-- Add billing method for recipients.
+alter type billing_method add value 'bill-recipient';
+
+-- Allow applications to use more billing methods at once.
+alter table application
+	add column billing_methods billing_method[] not null default '{}';
+
+update application set billing_methods = ARRAY[billing];
+
+alter table application drop column billing;
+
+-- Add a column to history for posterity when sending to contacts.
+alter table history add column userid varchar;

src/Pelican/API.hs

@@ -33,6 +33,7 @@ where
     route getReceiptR
     route getReceiptsR
     route postSendToNumberR
+    route postSendToContactR
 
 
   newtype ParamUUID = ParamUUID UUID
@@ -53,7 +54,7 @@ where
     where
       handle = do
         -- Read the request. Automatically dies on parsing error.
-        SendToNumbers{..} <- getJSON
+        SendToNumber{..} <- getJSON
 
         -- Check that the application is allowed to be billed.
         checkBilling BillSender application token
@@ -86,8 +87,8 @@ where
         sendText ""
 
 
-  data SendToNumbers
-    = SendToNumbers
+  data SendToNumber
+    = SendToNumber
       { number         :: PhoneNumber
       , payload        :: Text
       , interpolate    :: Maybe (Vector Text)
@@ -98,7 +99,77 @@ where
       }
     deriving (Show, Generic)
 
-  instance FromJSON SendToNumbers
+  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
@@ -203,15 +274,17 @@ where
 
   checkBilling :: Bill -> Text -> Text -> Action ()
   checkBilling needed appid token = do
-    billings <- fmap (fmap fromOnly) do
-      query [sql| select billing from application
+    methods' <- fmap (fmap fromOnly) do
+      query [sql| select billing_methods from application
                   where appid = ? and token = ? |] (appid, token)
 
-    when (billings == []) do
+    when (methods' == []) do
       abort unauthorized401 [] "Your application is not properly registered."
 
-    unless (needed `elem` billings) do
-      abort forbidden403 [] ("Requires " <> tshow needed <> " billing method.")
+    let methods = mconcat methods' :: Vector Bill
+
+    unless (needed `elem` methods) do
+      abort forbidden403 [] (tshow needed <> " not allowed for your app.")
 
 
   checkQuota :: Text -> Action ()

src/Pelican/Types.hs

@@ -37,15 +37,18 @@ where
 
   data Bill
     = BillSender
+    | BillRecipient
     deriving (Eq, Show, Ord, Enum, Bounded)
 
   instance FromJSON Bill where
     parseJSON = withText "Bill" \case
       "bill-sender"    -> return BillSender
+      "bill-recipient" -> return BillRecipient
       _otherwise       -> fail "invalid Bill format"
 
   instance ToField Bill where
     toField BillSender    = Escape "bill-sender"
+    toField BillRecipient = Escape "bill-recipient"
 
   instance FromField Bill where
     fromField f mdata = do
@@ -55,6 +58,7 @@ where
          else case fmap cs mdata of
                 Nothing               -> returnError UnexpectedNull f ""
                 Just "bill-sender"    -> return BillSender
+                Just "bill-recipient" -> return BillRecipient
                 Just x                -> returnError ConversionFailed f x