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
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
module Handler.List where
import Import
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy.Text
#ifdef THERMOPRINT
import Thermoprint.Client
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
#endif
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
, not $ itemRunningLow = itemNormKind == referenceNormKind
| otherwise = False
isBefore _ DateNever = True
isBefore _ DateUnknown = False
isBefore d1 (DateKnown d2) = d1 < d2
return $ Set.map (fmap referenceKind) references'
#ifdef THERMOPRINT
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
let
formatDraft (dId@(DraftId num), Nothing) =
("Draft #" <> tshow num, dId)
formatDraft (dId@(DraftId num), Just t) =
(t <> " (" <> tshow num <> ")", dId)
drafts' <- map formatDraft . Map.toAscList <$> drafts
list <- list
((printResult, printView), printEnc) <- runFormPost . identifyForm "print" . renderDivsNoLabels
$ case printers' of
[(_, pId)] -> pure pId
_ -> areq (selectFieldList printers') "Printer" . listToMaybe $ map snd printers'
((oDraftResult, oDraftView), oDraftEnc) <- runFormPost . identifyForm "oldDraft" . renderDivsNoLabels
$ areq (selectFieldList drafts') "Draft" Nothing
((nDraftResult, nDraftView), nDraftEnc) <- runFormPost . identifyForm "newDraft" . renderDivsNoLabels
$ areq textField "Title" Nothing
case printResult of
FormSuccess pId -> do
(JobId jId) <- jobCreate (Just pId) $ mkPrintout list
addMessage "printSuccess" [shamlet|List is printing as job ##{jId}|]
FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
_ -> return ()
case oDraftResult of
FormSuccess dId@(DraftId num) -> do
(t, printout) <- draft dId
let t' = fromMaybe "" t
draftReplace dId t $ printout `mappend` mkPrintout list
addMessage "appendSuccess" [shamlet|Appended shopping list to ‘#{t'}’ (#{num})|]
FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
_ -> return ()
case nDraftResult of
FormSuccess (Text.strip -> t) -> do
let t' = t <$ guard (not $ Text.null t)
(DraftId num) <- draftCreate t' $ mkPrintout list
addMessage "saveSuccess" [shamlet|Saved shopping list as ‘#{t}’ (#{num})|]
FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
_ -> return ()
selectRep $ do
provideJson $ typeToJSON "item" <$> Set.toAscList list
provideRep $ defaultLayout $(widgetFile "list")
#else
getListR, postListR :: Handler TypedContent
getListR = postListR
postListR = do
list <- list
selectRep $ do
provideJson $ typeToJSON "item" <$> Set.toAscList list
provideRep $ defaultLayout $(widgetFile "list-no-thermoprint")
#endif
|
