blob: 4209651f7fccd3b5b073e32b53dfcbefdeb834fc (
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
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
{-# 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 = runDB $ do
today <- liftIO $ utctDay <$> getCurrentTime
items <- map entityVal <$> selectList [] []
references <- Set.fromList <$> (withTypes . fmap entityVal =<< selectList [] [])
let
references' = Set.filter (isNothing . flip find items . matches) references
matches (Reference{..} `WithType` _) Item{..}
| today `isBefore` itemExpires = itemNormKind == referenceNormKind
| otherwise = False
isBefore _ DateNever = True
isBefore _ DateUnknown = False
isBefore d1 (DateKnown d2) = d1 < d2
return $ Set.map (fmap referenceKind) references'
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
|]
|
