Reference & list

1 files changed, 71 insertions, 0 deletions

diff --git a/Handler/List.hs b/Handler/List.hs
new file mode 100644
index 0000000..cfd3f7c
--- /dev/null
+++ b/Handler/List.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE OverloadedLists #-}
+
+module Handler.List where
+
+import Import
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as Lazy.Text
+
+import Database.Persist.Sql (Single(..), rawSql)
+
+import Thermoprint.Client
+
+list :: Handler (Set Text)
+list = do
+  (map unSingle -> kinds) <- runDB $ rawSql "select reference.kind from reference where not exists (select * from item where COALESCE(item.expires >= CURRENT_DATE, TRUE) and (item.norm_kind = reference.norm_kind)) " []
+  return $ Set.fromList kinds
+
+mkPrintout :: Set Text -> Printout
+mkPrintout list = Printout
+  [ Paragraph
+    [Cooked . either id Line . text . Lazy.Text.fromStrict . Text.unlines . map (" - " <>) $ Set.toAscList list 
+    ]
+  ]
+
+getListR, postListR :: Handler TypedContent
+getListR = postListR
+postListR = do
+  Client{..} <- mkClient' . appThermoprintBase . appSettings <$> getYesod
+  let
+    formatPrinter (pId@(PrinterId num), pStatus) =
+      ("Printer #" <> tshow num <> " – " <> tshow pStatus, pId)
+  printers' <- map formatPrinter . Map.toAscList <$> printers
+  list <- list
+
+  ((printResult, printView), printEnc) <- runFormPost . renderDivsNoLabels $ do
+    pId <- case printers' of
+      [(_, pId)] -> pure pId
+      _ -> areq (selectFieldList printers') "Printer" . listToMaybe $ map snd printers'
+    pure pId
+
+  case printResult of
+    FormSuccess pId -> do
+      (JobId jId) <- jobCreate (Just pId) $ mkPrintout list
+      addMessage "printSuccess" . toHtml $ "List is printing as job #" <> tshow jId
+    FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
+    _ -> return ()
+  
+  selectRep $ do
+    provideJson list
+    provideRep . defaultLayout $
+      [whamlet|
+              <div .table .main>
+                <div .tr .sepBelow>
+                  <div .th>Item
+                $forall item <- Set.toAscList list
+                  <div .tr .color>
+                    <div .kind>#{item}
+                <form .tr .sepAbove method=post action=@{ListR} enctype=#{printEnc}>
+                  <div .td>
+                    ^{printView}
+                    <button type=submit :Set.null list:disabled>
+                      Print
+              |]