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
|
{-# 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
, not $ itemRunningLow = 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
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")
|
