Skip to content
Snippets Groups Projects
Select Git revision
  • 49d4ebf3098d049bdca081946a150a9ab3e3d38d
  • test default protected
  • master protected
  • feat/custom-css
  • feat/redesign-improvements-10
  • feat/redesign-improvements-8
  • feat/redesign-fixes-3
  • feat/pirstan-changes
  • feat/separate-import-thread
  • feat/dary-improvements
  • features/add-pdf-page
  • features/add-typed-table
  • features/fix-broken-calendar-categories
  • features/add-embed-to-articles
  • features/create-mastodon-feed-block
  • features/add-custom-numbering-for-candidates
  • features/add-timeline
  • features/create-wordcloud-from-article-page
  • features/create-collapsible-extra-legal-info
  • features/extend-hero-banner
  • features/add-link-to-images
21 results

base.html

Blame
  • 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: