blob: 70f323a594ae919fa5dca841f05038505f9c04f9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
{-# 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 (WithType Text))
list = do
(map (uncurry WithType . bimap unSingle unSingle) -> kinds) <- runDB $ rawSql "select reference.kind, kind.type from reference,kind where (not exists (select * from item where COALESCE(item.expires >= CURRENT_DATE, TRUE) and (item.norm_kind = reference.norm_kind))) and (reference.norm_kind = kind.norm_kind)" []
return $ Set.fromList kinds
mkPrintout :: Set (WithType Text) -> Printout
mkPrintout list = Printout ps
where
ps = Map.foldMapWithKey (fmap (pure . Paragraph . pure . Cooked) . toLines) $ group list
group = Map.fromListWith (<>) . fmap (\(kind `WithType` t) -> (t, Set.singleton kind)) . Set.toAscList
toLines t (Set.toAscList -> kinds) = either id Line . text . Lazy.Text.fromStrict . Text.unlines $
pure t ++ map (" - " <>) kinds
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 $ typeToJSON "item" <$> Set.toAscList list
provideRep . defaultLayout $
[whamlet|
<table .main>
<tr .sepBelow>
<th>Item
<th>Type
$forall WithType item itemType <- Set.toAscList list
<tr .color>
<td .kind>#{item}
<td .type>#{itemType}
<tr .sepAbove>
<td colspan=2>
<form method=post action=@{ListR} enctype=#{printEnc}>
^{printView}
<button type=submit :Set.null list:disabled>
Print
|]
|
