More client functions

4 files changed, 70 insertions, 24 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")
diff --git a/templates/default-layout.cassius b/templates/default-layout.cassius
index 31389d8..e3aaa52 100644
--- a/templates/default-layout.cassius
+++ b/templates/default-layout.cassius
@@ -47,7 +47,7 @@ table table td, table table th, .table table td, .table table th
     margin: 0
   .formError
     color: #800
-  .printSuccess, .insertSuccess
+  .printSuccess, .insertSuccess, .appendSuccess, .saveSuccess
     color: #080
   .insertAmbiguous
     color: inherit
diff --git a/templates/list.cassius b/templates/list.cassius
new file mode 100644
index 0000000..5a4c58d
--- /dev/null
+++ b/templates/list.cassius
@@ -0,0 +1,4 @@
+#listActions form
+  display: block
+  div
+    display: inline-block
\ No newline at end of file
diff --git a/templates/list.hamlet b/templates/list.hamlet
new file mode 100644
index 0000000..a69ef1d
--- /dev/null
+++ b/templates/list.hamlet
@@ -0,0 +1,28 @@
+<div .table .main>
+  <div .tr .sepBelow>
+    <div .td>Item
+    <div .td>Type
+  $forall WithType item itemType <- Set.toAscList list
+    <div .tr .color>
+      <div .td .kind>#{item}
+      <div .td .type>#{itemType}
+    <form method=post enctype=#{nDraftEnc} .sepAbove .tr>
+      <div .td>
+        ^{nDraftView}
+      <div .td>
+        <button type=submit :Set.null list:disabled>
+          Save
+    $if not (null drafts')
+      <form method=post enctype=#{oDraftEnc} .tr>
+        <div .td>
+          ^{oDraftView}
+        <div .td>
+          <button type=submit :Set.null list:disabled>
+            Append
+    $if not (null printers')
+      <form method=post enctype=#{printEnc} .tr>
+        <div .td>
+          ^{printView}
+        <div .td>
+          <button type=submit :Set.null list:disabled>
+            Print