More client functions

1 files changed, 37 insertions, 23 deletions

diff --git a/Handler/List.hs b/Handler/List.hs
index 8f9e777..2fd745d 100644
--- a/Handler/List.hs
+++ b/Handler/List.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE OverloadedLists #-}
 
 module Handler.List where
@@ -50,17 +49,31 @@ 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 . renderDivsNoLabels $ do
-    pId <- case printers' of
-      [(_, pId)] -> pure pId
-      _ -> areq (selectFieldList printers') "Printer" . listToMaybe $ map snd printers'
-    pure pId
+  ((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
@@ -68,23 +81,24 @@ postListR = do
       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 $
-      [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
-              |]
+    provideRep . defaultLayout $ $(widgetFile "list")