Expand public web interface

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

README.md

@@ -75,19 +75,7 @@ Balíček je také možné nainstalovat:
 SMS brána v tuto chvíli vystavuje následující služby:
 
 
-### Uvítací stránka
-
-```http
-GET / HTTP/1.1
-```
-
-```http
-HTTP/1.1 200 OK
-Content-Type: text/html; charset=utf8
-```
-
-Vrací název aplikace a obrázek Pelikána z Wikimedia.
-
+### API
 
 ### Odeslání SMS zprávy na číslo
 

pelican.cabal

@@ -96,14 +96,17 @@ executable pelican
     other-modules:
         Paths_pelican
         Pelican.Action
+        Pelican.UI
+        Pelican.Public
         Pelican.API
         Pelican.Backend
+        Pelican.Backend.Failer
         Pelican.Backend.Fetcher
         Pelican.Backend.Sender
-        Pelican.Backend.Failer
         Pelican.Build
         Pelican.Common
         Pelican.Errors
+        Pelican.Main
         Pelican.Model
         Pelican.Site
         Pelican.Types

pelican.env

@@ -10,8 +10,11 @@ DATABASE = postgresql://pelican:pelican@localhost/pelican
 HTTP_PORT = 5000
 HTTP_ROOT = static
 
-# Stylesheet to use
-ASSET_STYLES = https://styleguide.pir-test.eu/2.3.x/styleguide/css/styleguide.min.css
+# Assets to use
+ASSET_VUE_JS   = https://cdn.jsdelivr.net/npm/vue@2.x
+ASSET_MAIN_CSS = https://styleguide.pir-test.eu/2.3.3/css/styles.css
+ASSET_MAIN_JS  = https://styleguide.pir-test.eu/2.3.3/js/main.bundle.js
+ASSET_LOGO     = https://styleguide.pir-test.eu/images/logo-round-white.svg
 
 # Base URL of the SMS gateway
 SMS_API = https://aweg.t-mobile.cz/

sql/009-views.sql

+-- Create views for basic message statistics.
+
+create view application_stats as
+	with s365 as (
+		select appid, sum(array_length(parts, 1))
+		from history where ts >= now() - interval '365 days'
+		group by appid
+	), s30 as (
+		select appid, sum(array_length(parts, 1))
+		from history where ts >= now() - interval '30 days'
+		group by appid
+	), s7 as (
+		select appid, sum(array_length(parts, 1))
+		from history where ts >= now() - interval '7 days'
+		group by appid
+	), s1 as (
+		select appid, sum(array_length(parts, 1))
+		from history where ts >= now() - interval '1 day'
+		group by appid
+	)
+	select	a.appid,
+		coalesce(s365.sum, 0) s365,
+		coalesce(s30.sum, 0) s30,
+		coalesce(s7.sum, 0) s7,
+		coalesce(s1.sum, 0) s1
+	from application a
+	left join s365 on s365.appid = a.appid
+	left join s30 on s30.appid = a.appid
+	left join s7 on s7.appid = a.appid
+	left join s1 on s1.appid = a.appid
+	order by 2 desc;
+
+create view cost_centre_stats as
+	with s365 as (
+		select cost_centre, sum(array_length(parts, 1))
+		from history where ts >= now() - interval '365 days'
+		group by cost_centre
+	), s30 as (
+		select cost_centre, sum(array_length(parts, 1))
+		from history where ts >= now() - interval '30 days'
+		group by cost_centre
+	), s7 as (
+		select cost_centre, sum(array_length(parts, 1))
+		from history where ts >= now() - interval '7 days'
+		group by cost_centre
+	), s1 as (
+		select cost_centre, sum(array_length(parts, 1))
+		from history where ts >= now() - interval '1 day'
+		group by cost_centre
+	)
+	select	cc.name,
+		cc.description,
+		coalesce(s365.sum, 0) s365,
+		coalesce(s30.sum, 0) s30,
+		coalesce(s7.sum, 0) s7,
+		coalesce(s1.sum, 0) s1
+	from cost_centre cc
+	left join s365 on s365.cost_centre = cc.name
+	left join s30 on s30.cost_centre = cc.name
+	left join s7 on s7.cost_centre = cc.name
+	left join s1 on s1.cost_centre = cc.name
+	order by 3 desc, 1 asc;
+
+-- Create view for detailed montly statistics.
+
+create view monthly_stats as
+	select	extract(year from ts)::bigint "year",
+		extract(month from ts)::bigint "month",
+		appid,
+		cost_centre,
+		sum(array_length(parts, 1))::bigint total
+	from history
+	group by year, month, appid, cost_centre
+	order by 1 asc, 2 asc, 5 desc;

src/Main.hs

@@ -3,75 +3,16 @@
 -- Copyright   :  Jan Hamal Dvořák
 -- License     :  AGPL-3.0-or-later
 --
--- Maintainer  :  jan.hamal.dvorak@pirati.cz
+-- Maintainer  :  mordae@anilinux.org
 -- Stability   :  unstable
 -- Portability :  non-portable (ghc)
 --
 
-module Main ( main
+module Main
+  ( main
   )
 where
-  import Praha
-  import Praha.Config.Environment
-
-  import UnliftIO.Environment (getProgName)
-
-  import Options.Applicative
-
-  import Pelican.Site (serve)
-  import Pelican.Build
-
-  import System.IO
-  import Data.List (reverse)
-
-
-  data Options
-    = Options
-      { optMainFunc    :: Options -> IO ()
-      , optConf        :: [FilePath]
-      }
-
-
-  mainFunc :: Parser (Options -> IO ())
-  mainFunc = flag' mainVersion ( long "version"
-                                 <> short 'V'
-                                 <> help "Show version information"
-                                 <> hidden
-                               )
-             <|> pure mainWebsite
-
-
-  options :: Parser Options
-  options = Options <$> mainFunc
-                    <*> many do
-                          strOption ( long "config"
-                                      <> short 'C'
-                                      <> help "Configuration file to read"
-                                    )
-
-
-  main :: IO ()
-  main = do
-    opts <- execParser $
-      info (helper *> options)
-           ( fullDesc
-             <> progDesc "Pirate SMS Gateway :-)"
-             <> footer "Report bugs at <http://gitlab.pirati.cz/to/pelican/issues>."
-           )
-
-    optMainFunc opts opts
-
-
-  mainVersion :: Options -> IO ()
-  mainVersion _opts = do
-    prog <- getProgName
-    putStrLn $ prog <> " " <> packageVersion
-
-
-  mainWebsite :: Options -> IO ()
-  mainWebsite Options{optConf} = do
-    mapM_ readFileToEnvDefault (reverse optConf)
-    serve
+  import Pelican.Main
 
 
 -- vim:set ft=haskell sw=2 ts=2 et:

src/Pelican/API.hs

@@ -14,10 +14,10 @@ module Pelican.API
 where
   import Praha
 
-  import Pelican.Types
   import Pelican.Action
   import Pelican.Common
   import Pelican.Model
+  import Pelican.Types
 
   import Data.Aeson as Aeson
   import Data.Text (splitOn)
@@ -30,8 +30,6 @@ where
 
   apiRoutes :: Dispatch (Action ()) TopLevel ()
   apiRoutes = do
-    route $ getRootR <$ get <* offerHTML
-
     route $ getReceiptR <$ get </ "v1" </ "receipt" <*> argWith fromText
                         <* offerJSON
 
@@ -47,16 +45,6 @@ where
     throwError Conflict (cs sqlErrorDetail)
 
 
-  getRootR :: Action ()
-  getRootR = do
-    sendHTML do
-      page_ "Pelican" do
-        h1_ "Pelican"
-        img_ [ src_ "https://upload.wikimedia.org/wikipedia/commons/thumb/d/d4/Pelikan_Walvis_Bay.jpg/480px-Pelikan_Walvis_Bay.jpg"
-             , alt_ "It's alive!"
-             ]
-
-
   postSendToNumberR :: Action ()
   postSendToNumberR = do
     -- Read the request. Automatically dies on parsing error.

src/Pelican/Common.hs

@@ -51,16 +51,27 @@ where
     doctypehtml_ $ do
       head_ $ do
         meta_ [charset_ "utf8"]
+        meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
         title_ title
 
-        stylesHref <- getConfig "ASSET_STYLES"
+        stylesHref <- getConfig "ASSET_MAIN_CSS"
 
-        link_ [ rel_ "stylesheet"
-              , href_ stylesHref
+        link_ [rel_ "stylesheet", href_ stylesHref]
+
+      body_ do
+        res <- body
+
+        vueHref <- getConfig "ASSET_VUE_JS"
+        script_ [ src_ vueHref
+                , crossorigin_ "anonymous"
+                ] (toHtml ("" :: Text))
+
+        scriptHref <- getConfig "ASSET_MAIN_JS"
+        script_ [ src_ scriptHref
                 , crossorigin_ "anonymous"
-              ]
+                ] (toHtml ("" :: Text))
 
-      body_ body
+        return res
 
 
   handlePgErrors :: (MonadUnliftIO m)

src/Pelican/Errors.hs

@@ -40,11 +40,15 @@ where
   errorPage title msg = do
     sendHTML do
       page_ (toHtml title) do
-        div_ [class_ "container vertical-margins"] do
-          h1_ [class_ "title"] do
+        div_ [class_ "container container--default grid grid-flow-col auto-cols-max gap-2 my-8"] do
+          div_ [class_ "head-alt-lg my-8 text-right"] do
+            "☒"
+
+          div_ do
+            h1_ [class_ "head-alt-lg my-8"] do
               toHtml title
 
-          p_ do
+            p_ [class_ "head-alt-md my-8"] do
               toHtml msg
 
 

src/Pelican/Main.hs

+-- |
+-- Module      :  Pelican.Main
+-- 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.Main
+  ( main
+  , develop
+  )
+where
+  import Praha
+  import Praha.Config.Environment
+
+  import Hikaru.Develop
+
+  import UnliftIO.Environment (getProgName)
+
+  import Options.Applicative
+
+  import Pelican.Site (serve)
+  import Pelican.Build
+
+  import System.IO
+  import Data.List (reverse)
+
+
+  data Options
+    = Options
+      { optMainFunc    :: Options -> IO ()
+      , optConf        :: [FilePath]
+      }
+
+
+  mainFunc :: Parser (Options -> IO ())
+  mainFunc = flag' mainVersion ( long "version"
+                                 <> short 'V'
+                                 <> help "Show version information"
+                                 <> hidden
+                               )
+             <|> pure mainWebsite
+
+
+  options :: Parser Options
+  options = Options <$> mainFunc
+                    <*> many do
+                          strOption ( long "config"
+                                      <> short 'C'
+                                      <> help "Configuration file to read"
+                                    )
+
+
+  main :: IO ()
+  main = do
+    opts <- execParser $
+      info (helper *> options)
+           ( fullDesc
+             <> progDesc "Pirate SMS Gateway :-)"
+             <> footer "Report bugs at <http://gitlab.pirati.cz/to/pelican/issues>."
+           )
+
+    optMainFunc opts opts
+
+
+  develop :: IO ()
+  develop = do
+    readFileToEnvDefault "pelican.env"
+    readFileToEnvDefault "test.env"
+    developWith main
+
+
+  mainVersion :: Options -> IO ()
+  mainVersion _opts = do
+    prog <- getProgName
+    putStrLn $ prog <> " " <> packageVersion
+
+
+  mainWebsite :: Options -> IO ()
+  mainWebsite Options{optConf} = do
+    mapM_ readFileToEnvDefault (reverse optConf)
+    serve
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:

src/Pelican/Public.hs

+-- |
+-- Module      :  Pelican.Public
+-- 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.Public
+  ( publicRoutes
+  )
+where
+  import Praha
+  import Praha.Config.Environment
+
+  import Pelican.Action
+  import Pelican.Common
+  import Pelican.Model
+  import Pelican.UI
+
+  import Hikaru.Link
+
+
+  publicRoutes :: Dispatch (Action ()) TopLevel ()
+  publicRoutes = do
+    route $ getRootR   <$ get <* offerHTML
+    route $ getAppR    <$ get </ "app" <*> arg </ "" <* offerHTML
+    route $ getCentreR <$ get </ "cc"  <*> arg </ "" <* offerHTML
+
+
+  getRootR :: Action ()
+  getRootR = do
+    sendHTML do
+      page_ "SMS Brána" do
+        pageMenu_
+        appStats_
+        ccStats_
+
+
+  getAppR :: Text -> Action ()
+  getAppR appid = do
+    ensureApp appid
+
+    months <- query [sql| select year, month, sum(total)::bigint
+                          from monthly_stats where appid = ?
+                          group by year, month |] (Only appid)
+
+    sendHTML do
+      page_ (toHtml appid) do
+        pageMenu_
+        section_ [class_ "container container--default my-16"] do
+          h1_ [class_ "head-alt-lg my-8"] (toHtml appid)
+          h3_ [class_ "head-alt-md"] "Odeslané zprávy po měsících"
+
+          div_ [class_ "overflow-x-auto"] do
+            table_ [class_ "table my-2"] do
+              tr_ do
+                th_ [class_ "text-right"] "Rok"
+                th_ [class_ "text-right"] "Měsíc"
+                th_ [class_ "text-right"] "Odesláno"
+
+              forM_ months \(year :: Int, month :: Int, total :: Int) -> do
+                tr_ do
+                  td_ [class_ "text-right"] $ toHtml (tshow year)
+                  td_ [class_ "text-right"] $ toHtml (tshow month)
+                  td_ [class_ "text-right"] $ toHtml (tshow total)
+
+
+  getCentreR :: Text -> Action ()
+  getCentreR ccid = do
+    desc   <- ensureCostCentre ccid
+    months <- query [sql| select year, month, appid, sum(total)::bigint
+                          from monthly_stats where cost_centre = ?
+                          group by year, month, appid
+                          order by 1 asc, 2 asc, 4 desc |] (Only ccid)
+
+    sendHTML do
+      page_ (toHtml ccid) do
+        pageMenu_
+        section_ [class_ "container container--default my-16"] do
+          h1_ [class_ "head-alt-lg mt-8"] (toHtml ccid)
+          h2_ [class_ "head-alt-md mb-8"] (toHtml desc)
+          h3_ [class_ "head-alt-md"] "Odeslané zprávy po měsících"
+
+          div_ [class_ "overflow-x-auto"] do
+            table_ [class_ "table my-2"] do
+              tr_ do
+                th_ [class_ "text-right w-32"] "Rok"
+                th_ [class_ "text-right w-32"] "Měsíc"
+                th_ [class_ "text-left"]       "Aplikace"
+                th_ [class_ "text-right w-32"] "Odesláno"
+
+              forM_ months \(year, month, appid, total) -> do
+                tr_ do
+                  td_ [class_ "text-right"] $ toHtml (tshow (year :: Int))
+                  td_ [class_ "text-right"] $ toHtml (tshow (month :: Int))
+                  td_ [class_ "text-left"]  $ toHtml (appid :: Text)
+                  td_ [class_ "text-right"] $ toHtml (tshow (total :: Int))
+
+
+  ensureApp :: Text -> Action ()
+  ensureApp appid = do
+    Only n <- query1 "select count(*) from application where appid = ?"
+                     (Only appid)
+
+    if (n :: Int) > 0
+       then return ()
+       else throwError NotFound "No such application."
+
+
+  ensureCostCentre :: Text -> Action Text
+  ensureCostCentre ccid = do
+    descs <- query "select description from cost_centre where name = ?"
+                   (Only ccid)
+
+    case descs of
+      (Only desc : _) -> return desc
+      _otherwise      -> throwError NotFound "No such cost centre."
+
+
+  -- Fragments ---------------------------------------------------------------
+
+
+  pageMenu_ :: HtmlT Action ()
+  pageMenu_ = do
+    logoHref <- getConfig "ASSET_LOGO"
+
+    nav_ [class_ "navbar navbar--simple __js-root"] do
+      uiApp_ [inlineTemplate_] do
+        uiNavbar_ [inlineTemplate_] do
+          div_ [ class_ "container container--default navbar__content"
+               , jsClass_ "{'navbar__content--initialized': true}" ] do
+            div_ [class_ "navbar__brand my-4 flex items-center lg:pr-8 lg:my-0"] do
+              a_ [href_ "/"] do
+                img_ [src_ logoHref, class_ "w-8"]
+              span_ [class_ "pl-4 font-bold text-xl lg:border-r lg:border-grey-300 lg:pr-8"] do
+                  "SMS Brána"
+
+            div_ [class_ "navbar__menutoggle my-4 flex justify-end lg:hidden"] do
+              a_ [ href_ "#"
+                 , atClick_ "show = !show"
+                 , class_ "no-underline hover:no-underline"] do
+                i_ [class_ "ico--menu text-3xl"] ""
+
+            div_ [ vIf_ "show || isLgScreenSize"
+                 , class_ "navbar__main navbar__section navbar__section--expandable container-padding--zero lg:container-padding--auto flex items-center"] do
+              div_ [class_ "flex-grow"] do
+                ul_ [class_ "navbar-menu text-white"] do
+                  li_ [class_ "navbar-menu__item"] do
+                    a_ [href_ "/", class_ "navbar-menu__link"] do
+                      "Statistiky"
+
+
+  appStats_ :: HtmlT Action ()
+  appStats_ = do
+    section_ [class_ "container container--default my-16"] do
+      h1_ [class_ "head-alt-md"] "Odeslané zprávy po aplikacích"
+
+      div_ [class_ "overflow-x-auto"] do
+        table_ [class_ "table my-2 w-full"] do
+          tr_ do
+            th_ [class_ "text-left"] "Aplikace"
+            th_ [class_ "text-right w-32"] "za 365 dnů"
+            th_ [class_ "text-right w-32"] "za 30 dnů"
+            th_ [class_ "text-right w-32"] "za týden"
+            th_ [class_ "text-right w-32"] "dnes"
+
+          stats <- query "select * from application_stats" ()
+
+          forM_ stats \(name, s365, s30, s7, s1) -> do
+            tr_ do
+              td_ [class_ "text-left font-bold"] do
+                a_ [phref_ ["app", name, ""]] do
+                  toHtml (name :: Text)
+
+              td_ [class_ "text-right"] $ toHtml (tshow (s365 :: Int))
+              td_ [class_ "text-right"] $ toHtml (tshow (s30 :: Int))
+              td_ [class_ "text-right"] $ toHtml (tshow (s7 :: Int))
+              td_ [class_ "text-right"] $ toHtml (tshow (s1 :: Int))
+
+
+  ccStats_ :: HtmlT Action ()
+  ccStats_ = do
+    section_ [class_ "container container--default my-16"] do
+      h1_ [class_ "head-alt-md"] "Odeslané zprávy po střediscích"
+
+      div_ [class_ "overflow-x-auto"] do
+        table_ [class_ "table my-2 w-full"] do
+          tr_ do
+            th_ [class_ "text-center w-32"] "Stř."
+            th_ [class_ "text-left"] "Popis"
+            th_ [class_ "text-right w-32"] "za 365 dnů"
+            th_ [class_ "text-right w-32"] "za 30 dnů"
+            th_ [class_ "text-right w-32"] "za týden"
+            th_ [class_ "text-right w-32"] "dnes"
+
+          stats <- query "select* from cost_centre_stats" ()
+          forM_ stats \(name, description, s365, s30, s7, s1) -> do
+            tr_ do
+              td_ [class_ "text-center font-bold"] do
+                a_ [phref_ ["cc", name, ""]] do
+                  toHtml (name :: Text)
+
+              td_ [class_ "text-left"]  $ toHtml (description :: Text)
+              td_ [class_ "text-right"] $ toHtml (tshow (s365 :: Int))
+              td_ [class_ "text-right"] $ toHtml (tshow (s30 :: Int))
+              td_ [class_ "text-right"] $ toHtml (tshow (s7 :: Int))
+              td_ [class_ "text-right"] $ toHtml (tshow (s1 :: Int))
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:

src/Pelican/Site.hs

@@ -21,11 +21,12 @@ where
   import Pelican.Action
   import Pelican.API
   import Pelican.Backend
+  import Pelican.Backend.Failer
   import Pelican.Backend.Fetcher
   import Pelican.Backend.Sender
-  import Pelican.Backend.Failer
   import Pelican.Errors
   import Pelican.Model
+  import Pelican.Public
 
   import UnliftIO.Async (mapConcurrently_)
   import UnliftIO.Pool (Pool, createPool, withResource)
@@ -74,6 +75,9 @@ where
         handler NotFound notFoundR
         handler Forbidden forbiddenR
 
+        -- Register routes for the public website.
+        publicRoutes
+
         -- Register routes for the RESTful API.
         apiRoutes
 

src/Pelican/UI.hs

+-- |
+-- Module      :  Pelican.UI
+-- Copyright   :  Jan Hamal Dvořák
+-- License     :  AGPL-3.0-or-later
+--
+-- Maintainer  :  mordae@anilinux.org
+-- Stability   :  unstable
+-- Portability :  non-portable (ghc)
+--
+-- This module wraps the Pirate Styleguide 2.3.x.
+--
+
+module Pelican.UI
+  ( uiApp_
+  , uiNavbar_
+  , uiNavbarSubitem_
+  , inlineTemplate_
+  , jsClass_
+  , atClick_
+  , vIf_
+  )
+where
+  import Praha
+
+  import Lucid
+  import Lucid.Base
+
+
+  uiApp_ :: Term arg result => arg -> result
+  uiApp_ = term "ui-app"
+
+
+  uiNavbar_ :: Term arg result => arg -> result
+  uiNavbar_ = term "ui-navbar"
+
+
+  uiNavbarSubitem_ :: Term arg result => arg -> result
+  uiNavbarSubitem_ = term "ui-navbar-subitem"
+
+
+  inlineTemplate_ :: Attribute
+  inlineTemplate_ = makeAttribute "inline-template" ""
+
+
+  jsClass_ :: Text -> Attribute
+  jsClass_ = makeAttribute ":class"
+
+
+  atClick_ :: Text -> Attribute
+  atClick_ = makeAttribute "@click"
+
+
+  vIf_ :: Text -> Attribute
+  vIf_ = makeAttribute "v-if"
+
+
+-- vim:set ft=haskell sw=2 ts=2 et: