From 7bc954b779a9bc4e1c5e60f2648101c62ed22e72 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Tue, 14 Mar 2017 18:33:42 +0100
Subject: Reference & list

---
 Application.hs                    |  5 +++
 Foundation.hs                     | 11 ++++++
 Handler/Common.hs                 | 64 ++++++++++++++++++++++++++++++++---
 Handler/Common/Types.hs           | 23 +++++++++++--
 Handler/DeleteRefItem.hs          | 10 ++++++
 Handler/InventoryListing.hs       |  2 +-
 Handler/Item.hs                   | 10 +++---
 Handler/Kinds.hs                  |  8 +++++
 Handler/List.hs                   | 71 +++++++++++++++++++++++++++++++++++++++
 Handler/ReferenceItem.hs          | 25 ++++++++++++++
 Handler/ReferenceListing.hs       | 27 +++++++++++++++
 Handler/UpdateItem.hs             | 20 +++++------
 Settings.hs                       |  7 ++++
 bar.cabal                         |  6 ++++
 bar.nix                           | 12 +++----
 config/routes                     |  6 ++++
 config/settings.yml               |  2 ++
 shell.nix                         |  2 +-
 stack.yaml                        |  2 +-
 templates/default-layout.cassius  | 44 +++++++++++++++---------
 templates/inventoryListing.hamlet |  4 +--
 templates/referenceListing.hamlet | 17 ++++++++++
 22 files changed, 327 insertions(+), 51 deletions(-)
 create mode 100644 Handler/DeleteRefItem.hs
 create mode 100644 Handler/Kinds.hs
 create mode 100644 Handler/List.hs
 create mode 100644 Handler/ReferenceItem.hs
 create mode 100644 Handler/ReferenceListing.hs
 create mode 100644 templates/referenceListing.hamlet

diff --git a/Application.hs b/Application.hs
index 048a316..85ceb2f 100644
--- a/Application.hs
+++ b/Application.hs
@@ -37,6 +37,11 @@ import Handler.UpdateItem
 import Handler.OpenItem
 import Handler.DeleteItem
 import Handler.Item
+import Handler.ReferenceListing
+import Handler.ReferenceItem
+import Handler.DeleteRefItem
+import Handler.Kinds
+import Handler.List
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
diff --git a/Foundation.hs b/Foundation.hs
index d192c08..d7425d5 100644
--- a/Foundation.hs
+++ b/Foundation.hs
@@ -78,6 +78,13 @@ instance Yesod App where
         -- Define the menu items of the header.
         let menuItems =
               [ MenuItem "Inventory" InventoryListingR
+              , MenuItem "Reference" ReferenceListingR
+              , MenuItem "List" ListR
+              ]
+            currentMenu = listToMaybe
+              [ menuItemLabel
+              | MenuItem{..} <- menuItems
+              , Just menuItemRoute == mCurrentRoute
               ]
 
         -- We break up the default layout into two components:
@@ -87,6 +94,10 @@ instance Yesod App where
         -- you to use normal widget features in default-layout.
 
         pc <- widgetToPageContent $ do
+          setTitle . toHtml . maybe "Bar Inventory" ("Bar Inventory – " <>) $ do
+            cM <- currentMenu
+            guard $ cM /= "Inventory"
+            return cM
           addScript $ StaticR jquery_js
           addScript $ StaticR webshim_polyfiller_js
           $(widgetFile "default-layout")
diff --git a/Handler/Common.hs b/Handler/Common.hs
index 38fb1ce..2416d15 100644
--- a/Handler/Common.hs
+++ b/Handler/Common.hs
@@ -3,8 +3,13 @@
 module Handler.Common
   ( inventoryListing
   , itemForm
+  , referenceListing
+  , referenceForm
+  , kinds
   , InventoryState(..)
+  , ReferenceState(..)
   , FormState(..)
+  , HasFormState(..)
   ) where
 
 import Import
@@ -25,7 +30,7 @@ itemForm :: Maybe Item -- ^ Update existing item or insert new?
 itemForm proto identView = do
   today <- utctDay <$> liftIO getCurrentTime
   
-  (kindRes, kindView) <- mreq textField "" $ itemKind <$> proto
+  (kindRes, kindWidget) <- kindField $ itemKind <$> proto
   (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown"
   (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never"
   (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never"
@@ -41,7 +46,7 @@ itemForm proto identView = do
     [whamlet|
             $newline never
             #{identView}
-            <div .td>^{fvInput kindView}
+            <div .td>^{kindWidget}
             <div .td>^{boughtWidget}
             <div .td>^{expiresWidget}
             <div .td>^{openedWidget}
@@ -73,6 +78,55 @@ itemForm proto identView = do
                 |]
 
 inventoryListing :: InventoryState -> Widget
-inventoryListing InventoryState{..} = do
-  setTitle "Bar Inventory"
-  $(widgetFile "inventoryListing")
+inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing")
+
+referenceForm :: Maybe Reference -- ^ Update existing item or insert new?
+              -> Html -> MForm Handler (FormResult Reference, Widget)
+referenceForm proto identView = do
+  (kindRes, kindWidget) <- kindField $ referenceKind <$> proto
+
+  let referenceRes = do
+        referenceKind <- kindRes
+        return Reference{ referenceNormKind = normalizeKind referenceKind, .. }
+
+  return . (referenceRes, ) $
+    [whamlet|
+            $newline never
+            #{identView}
+            <div .td>^{kindWidget}
+            |]
+
+referenceListing :: ReferenceState -> Widget
+referenceListing ReferenceState{ refFormState = formState, ..} = $(widgetFile "referenceListing")
+
+kindField :: Maybe Text -> MForm Handler (FormResult Text, Widget)
+kindField proto = do
+  optionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique
+
+  let
+    attrs = [ ("list", optionId)
+            , ("autocomplete", "off")
+            ]
+  
+  (kindRes, kindView) <- mreq textField ("" { fsAttrs = attrs }) proto
+
+  options <- lift kinds
+
+  return . (kindRes, ) $
+    [whamlet|
+            $newline never
+            ^{fvInput kindView}
+            <datalist ##{optionId}>
+              $forall opt <- options
+                <option value=#{opt}>
+            |]
+
+kinds :: Handler [Text]
+kinds = do
+  stock <- runDB $ selectList [] []
+  reference <- runDB $ selectList [] []
+
+  return $ concat
+    [ [ itemKind | Entity _ Item{..} <- stock ]
+    , [ referenceKind | Entity _ Reference{..} <- reference ]
+    ]
diff --git a/Handler/Common/Types.hs b/Handler/Common/Types.hs
index ca7cb8d..08653af 100644
--- a/Handler/Common/Types.hs
+++ b/Handler/Common/Types.hs
@@ -8,15 +8,32 @@ import Control.Lens
 
 data InventoryState = InventoryState
   { stock :: [Entity Item]
-  , formState :: Maybe FormState
+  , invFormState :: Maybe (FormState ItemId)
   }
 
-data FormState = InsertForm
+data ReferenceState = ReferenceState
+  { reference :: [Entity Reference]
+  , refFormState :: Maybe (FormState ReferenceId)
+  }
+
+class HasFormState a where
+  type family UpdateId a :: *
+  formState :: a -> Maybe (FormState (UpdateId a))
+
+instance HasFormState InventoryState where
+  type UpdateId InventoryState = ItemId
+  formState = invFormState
+
+instance HasFormState ReferenceState where
+  type UpdateId ReferenceState = ReferenceId
+  formState = refFormState
+  
+data FormState id = InsertForm
                  { fsInsertForm :: Widget
                  , fsInsertEncoding :: Enctype
                  }
                | UpdateForm
-                 { fsUpdateItem :: ItemId
+                 { fsUpdateId :: id
                  , fsUpdateForm :: Widget
                  , fsUpdateEncoding :: Enctype
                  }
diff --git a/Handler/DeleteRefItem.hs b/Handler/DeleteRefItem.hs
new file mode 100644
index 0000000..c4ff519
--- /dev/null
+++ b/Handler/DeleteRefItem.hs
@@ -0,0 +1,10 @@
+module Handler.DeleteRefItem where
+
+import Import
+
+postDeleteRefItemR :: ReferenceId -> Handler TypedContent
+postDeleteRefItemR referenceId = do
+  runDB $ delete referenceId
+  selectRep $ do
+    provideJson ()
+    provideRep (redirect $ ReferenceListingR :: Handler Html)
diff --git a/Handler/InventoryListing.hs b/Handler/InventoryListing.hs
index e3c062e..12f36ba 100644
--- a/Handler/InventoryListing.hs
+++ b/Handler/InventoryListing.hs
@@ -18,7 +18,7 @@ postInventoryListingR = do
   selectRep $ do
     provideJson (stock :: [Entity Item])
     provideRep . defaultLayout $ inventoryListing InventoryState
-      { formState = Just InsertForm{..}
+      { invFormState = Just InsertForm{..}
       , ..
       }
 
diff --git a/Handler/Item.hs b/Handler/Item.hs
index 87030bb..0f48261 100644
--- a/Handler/Item.hs
+++ b/Handler/Item.hs
@@ -4,12 +4,10 @@ import Import
 
 getItemR :: ItemId -> Handler TypedContent
 getItemR itemId = do
-  eLookup <- runDB $ fmap (Entity itemId) <$> get itemId
-  case eLookup of
-    Nothing -> notFound
-    Just entity -> selectRep $ do
-      provideJson entity
-      provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
+  entity <- runDB $ Entity itemId <$> get404 itemId
+  selectRep $ do
+    provideJson entity
+    provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
 
 putItemR :: ItemId -> Handler Value
 putItemR itemId = do
diff --git a/Handler/Kinds.hs b/Handler/Kinds.hs
new file mode 100644
index 0000000..0843c70
--- /dev/null
+++ b/Handler/Kinds.hs
@@ -0,0 +1,8 @@
+module Handler.Kinds where
+
+import Import
+
+import Handler.Common
+
+getKindsR :: Handler Value
+getKindsR = returnJson =<< kinds
diff --git a/Handler/List.hs b/Handler/List.hs
new file mode 100644
index 0000000..cfd3f7c
--- /dev/null
+++ b/Handler/List.hs
@@ -0,0 +1,71 @@
+{-# 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 Text)
+list = do
+  (map unSingle -> kinds) <- runDB $ rawSql "select reference.kind from reference where not exists (select * from item where COALESCE(item.expires >= CURRENT_DATE, TRUE) and (item.norm_kind = reference.norm_kind)) " []
+  return $ Set.fromList kinds
+
+mkPrintout :: Set Text -> Printout
+mkPrintout list = Printout
+  [ Paragraph
+    [Cooked . either id Line . text . Lazy.Text.fromStrict . Text.unlines . map (" - " <>) $ Set.toAscList list 
+    ]
+  ]
+
+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 list
+    provideRep . defaultLayout $
+      [whamlet|
+              <div .table .main>
+                <div .tr .sepBelow>
+                  <div .th>Item
+                $forall item <- Set.toAscList list
+                  <div .tr .color>
+                    <div .kind>#{item}
+                <form .tr .sepAbove method=post action=@{ListR} enctype=#{printEnc}>
+                  <div .td>
+                    ^{printView}
+                    <button type=submit :Set.null list:disabled>
+                      Print
+              |]
diff --git a/Handler/ReferenceItem.hs b/Handler/ReferenceItem.hs
new file mode 100644
index 0000000..738c9f3
--- /dev/null
+++ b/Handler/ReferenceItem.hs
@@ -0,0 +1,25 @@
+module Handler.ReferenceItem where
+
+import Import
+
+getReferenceItemR :: ReferenceId -> Handler TypedContent
+getReferenceItemR referenceId = do
+  entity <- runDB $ Entity referenceId <$> get404 referenceId
+  selectRep $ do
+    provideJson entity
+    provideRep (redirect $ ReferenceListingR :#: referenceId :: Handler Html)
+
+
+putReferenceItemR :: ReferenceId -> Handler Value
+putReferenceItemR referenceId = do
+  Reference{..} <- requireCheckJsonBody
+  returnJson . Entity referenceId =<< runDB
+    (updateGet referenceId [ ReferenceKind =. referenceKind
+                           , ReferenceNormKind =. referenceNormKind
+                           ])
+
+patchReferenceItemR :: ReferenceId -> Handler Value
+patchReferenceItemR = putReferenceItemR -- Just one field
+
+deleteReferenceItemR :: ReferenceId -> Handler ()
+deleteReferenceItemR = runDB . delete
diff --git a/Handler/ReferenceListing.hs b/Handler/ReferenceListing.hs
new file mode 100644
index 0000000..0f777ee
--- /dev/null
+++ b/Handler/ReferenceListing.hs
@@ -0,0 +1,27 @@
+module Handler.ReferenceListing where
+
+import Import
+
+import Handler.Common
+
+getReferenceListingR, postReferenceListingR :: Handler TypedContent
+getReferenceListingR = postReferenceListingR
+postReferenceListingR = do
+  ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ referenceForm Nothing
+
+  mapM_ (addMessage "formError" . toHtml) =<< case insertResult of 
+    FormSuccess newReference -> [] <$ runDB (insert newReference)
+    FormFailure errors -> return errors
+    _ -> return []
+
+  reference <- runDB $ selectList [] [Asc ReferenceKind]
+
+  selectRep $ do
+    provideJson (reference :: [Entity Reference])
+    provideRep . defaultLayout $ referenceListing ReferenceState
+      { refFormState = Just InsertForm{..}
+      , ..
+      }
+
+putReferenceListingR :: Handler Value
+putReferenceListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Reference)
diff --git a/Handler/UpdateItem.hs b/Handler/UpdateItem.hs
index 353572b..a4a29c2 100644
--- a/Handler/UpdateItem.hs
+++ b/Handler/UpdateItem.hs
@@ -6,28 +6,28 @@ import Handler.Common
 
 getUpdateItemR, postUpdateItemR :: ItemId -> Handler TypedContent
 getUpdateItemR = postUpdateItemR
-postUpdateItemR fsUpdateItem = do
-  Just entity <- fmap (Entity fsUpdateItem) <$> runDB (get fsUpdateItem)
+postUpdateItemR fsUpdateId = do
+  Just entity <- fmap (Entity fsUpdateId) <$> runDB (get fsUpdateId)
   
   ((updateResult, fsUpdateForm), fsUpdateEncoding) <- runFormPost . itemForm . Just $ entityVal entity
 
   mapM_ (addMessage "formError" . toHtml) =<< case updateResult of 
-    FormSuccess Item{..} -> [] <$ runDB (update fsUpdateItem [ ItemKind =. itemKind
-                                                             , ItemNormKind =. normalizeKind itemKind
-                                                             , ItemBought =. itemBought
-                                                             , ItemExpires =. itemExpires
-                                                             , ItemOpened =. itemOpened
-                                                             ])
+    FormSuccess Item{..} -> [] <$ runDB (update fsUpdateId [ ItemKind =. itemKind
+                                                           , ItemNormKind =. normalizeKind itemKind
+                                                           , ItemBought =. itemBought
+                                                           , ItemExpires =. itemExpires
+                                                           , ItemOpened =. itemOpened
+                                                           ])
     FormFailure errors -> return errors
     _ -> return []
 
   selectRep $ do
     provideRep $ case updateResult of
-      FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateItem :: Handler Html
+      FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateId :: Handler Html
       _ -> do
         (sortOn entityVal -> stock) <- runDB $ selectList [] []
         defaultLayout $ inventoryListing InventoryState
-          { formState = Just UpdateForm{..}
+          { invFormState = Just UpdateForm{..}
           , ..
           }
     provideJson ()
diff --git a/Settings.hs b/Settings.hs
index 63cbd15..d0e16ea 100644
--- a/Settings.hs
+++ b/Settings.hs
@@ -19,6 +19,8 @@ import Yesod.Default.Config2       (applyEnvValue, configSettingsYml)
 import Yesod.Default.Util          (WidgetFileSettings, widgetFileNoReload,
                                     widgetFileReload)
 
+import Thermoprint.Client (BaseUrl(..), Scheme(..), InvalidBaseUrlException, parseBaseUrl)
+
 #ifdef DEVELOPMENT
 #define DEV_BOOL True
 #else
@@ -47,11 +49,14 @@ data AppSettings = AppSettings
     -- ^ Should all log messages be displayed?
     , appReloadTemplates        :: Bool
     -- ^ Use the reload version of templates
+
+    , appThermoprintBase        :: BaseUrl
     }
 
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
         let defaultDev = DEV_BOOL
+            parseUrl' = either (fail . show) return . parseBaseUrl
         appStaticDir              <- o .: "static-dir"
         appDatabaseConf           <- o .: "database"
         appHost                   <- fromString <$> o .: "host"
@@ -62,6 +67,8 @@ instance FromJSON AppSettings where
         appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev
         appReloadTemplates        <- o .:? "reload-templates" .!= defaultDev
 
+        appThermoprintBase        <- parseUrl' =<< o .: "thermoprint-url"
+
         return AppSettings {..}
 
 -- | Settings for 'widgetFile', such as which template languages to support and
diff --git a/bar.cabal b/bar.cabal
index 264339d..1d25e21 100644
--- a/bar.cabal
+++ b/bar.cabal
@@ -27,6 +27,11 @@ library
                      Handler.OpenItem
                      Handler.DeleteItem
                      Handler.Item
+                     Handler.ReferenceListing
+                     Handler.ReferenceItem
+                     Handler.DeleteRefItem
+                     Handler.Kinds
+                     Handler.List
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT
@@ -98,6 +103,7 @@ library
                  , wai
                  , mtl
                  , lens
+                 , thermoprint-client
 
 executable         bar
     if flag(library-only)
diff --git a/bar.nix b/bar.nix
index ff25b88..7fb7da0 100644
--- a/bar.nix
+++ b/bar.nix
@@ -4,9 +4,9 @@
 , file-embed, hjsmin, http-conduit, lens, monad-control
 , monad-logger, mtl, persistent, persistent-postgresql
 , persistent-template, safe, shakespeare, stdenv, template-haskell
-, text, time, unordered-containers, vector, wai, wai-extra
-, wai-logger, warp, yaml, yesod, yesod-auth, yesod-core, yesod-form
-, yesod-static
+, text, thermoprint-client, thermoprint-spec, time
+, unordered-containers, vector, wai, wai-extra, wai-logger, warp
+, yaml, yesod, yesod-auth, yesod-core, yesod-form, yesod-static
 }:
 mkDerivation {
   pname = "bar";
@@ -20,9 +20,9 @@ mkDerivation {
     data-default directory fast-logger file-embed hjsmin http-conduit
     lens monad-control monad-logger mtl persistent
     persistent-postgresql persistent-template safe shakespeare
-    template-haskell text time unordered-containers vector wai
-    wai-extra wai-logger warp yaml yesod yesod-auth yesod-core
-    yesod-form yesod-static
+    template-haskell text thermoprint-client thermoprint-spec time
+    unordered-containers vector wai wai-extra wai-logger warp yaml
+    yesod yesod-auth yesod-core yesod-form yesod-static
   ];
   executableHaskellDepends = [ base ];
   doHaddock = false;
diff --git a/config/routes b/config/routes
index 54d6593..08babf4 100644
--- a/config/routes
+++ b/config/routes
@@ -5,3 +5,9 @@
 /inv/#ItemId/open OpenItemR POST
 /inv/#ItemId/delete DeleteItemR POST
 /inv/#ItemId ItemR GET PUT PATCH DELETE
+
+/ref ReferenceListingR GET POST PUT
+/ref/#ReferenceId ReferenceItemR GET PUT PATCH DELETE
+/ref/#ReferenceId/delete DeleteRefItemR POST
+/kinds KindsR GET
+/list ListR GET POST
diff --git a/config/settings.yml b/config/settings.yml
index 83d3bfc..c867908 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -10,6 +10,8 @@ ip-from-header: "_env:IP_FROM_HEADER:false"
 # should-log-all: false
 # reload-templates: false
 
+thermoprint-url: "_env:TPRINT_BASEURL:http://localhost:3000"
+
 database:
   user:     "_env:PGUSER:bar"
   password: "_env:PGPASS:"
diff --git a/shell.nix b/shell.nix
index b6595aa..c6a13de 100644
--- a/shell.nix
+++ b/shell.nix
@@ -10,7 +10,7 @@ let
   drv = haskellPackages.callPackage ./bar.nix {};
 in
   pkgs.stdenv.lib.overrideDerivation drv.env (oldAttrs: {
-    buildInputs = oldAttrs.buildInputs ++ (with pkgs; [ cabal2nix gup haskellPackages.hlint haskellPackages.stack haskellPackages.yesod-bin ]);
+    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ cabal2nix gup ]) ++ (with haskellPackages; [ hlint stack yesod-bin alex ]);
     shellHook = ''
       ${oldAttrs.shellHook}
       export PROMPT_INFO="${oldAttrs.name}"
diff --git a/stack.yaml b/stack.yaml
index 776a6b4..161b308 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -15,7 +15,7 @@
 # resolver:
 #  name: custom-snapshot
 #  location: "./custom-snapshot.yaml"
-resolver: lts-8.5
+resolver: ghc-8.0.2
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
diff --git a/templates/default-layout.cassius b/templates/default-layout.cassius
index 492cde8..c1ccf72 100644
--- a/templates/default-layout.cassius
+++ b/templates/default-layout.cassius
@@ -1,5 +1,8 @@
+.main
+  min-width: 20em
 .table
   display: table
+  border-collapse: collapse
 .table div
   vertical-align: middle
 .td
@@ -21,25 +24,32 @@
   display: table-cell
   text-align: left
   padding: 0.25em
+.kind:only-child
+  text-align: center
 .table .table .td, .table .table .tc, .table .table .th, .table .table .kind
   padding: 0
-.error
-  background-color: #fdd
-  text-align: center
-  color: #c00
+#messages
   list-style-type: none
+  margin: 1em auto 1em 0
+  padding: 0
+  text-align: center
+  font-weight: bold
+  .formError
+    color: #800
+  .printSuccess
+    color: #080
 button
   width: 6em
-  display:inline-text
+  display: inline-block
 .day hr
   width: 2em
   border: 1px solid #ddd
   border-style: solid none solid none
-.sepBelow > div, .sepAbove > div
+.sepBelow, .sepAbove
   border: 2px none #ddd
-.sepBelow > div
+.sepBelow
   border-bottom-style: solid
-.sepAbove > div
+.sepAbove
   border-top-style: solid
 .color:nth-child(even)
   background-color: #f0f0f0
@@ -50,26 +60,28 @@ body > div
 .table > h1
   display: table-caption
 nav ul
-  display:block
+  display: block
   text-align: center
+  padding: 0
   li
-    display:inline-block
+    display: inline-block
     font-variant: small-caps
     font-size: 1.5em
     font-weight: bold
     a
-      text-decoration:none
-      color:#aaa
+      text-decoration: underline
+      color: #aaa
     a:hover
-      color:inherit
+      text-decoration: none
   li.active
     a
-      color:inherit
+      color: inherit
+      text-decoration: none
   li::before
-    content:" | "
+    content: " | "
     color: #ddd
   li:first-child::before
-    content:""
+    content: ""
 label.checkbox
   input
     vertical-align: middle
diff --git a/templates/inventoryListing.hamlet b/templates/inventoryListing.hamlet
index 7c2c06b..be80993 100644
--- a/templates/inventoryListing.hamlet
+++ b/templates/inventoryListing.hamlet
@@ -13,9 +13,9 @@
           <button type=submit>
             Insert
   $forall Entity itemId Item{..} <- stock
-    $if Just itemId == (preview updateItem =<< formState)
+    $if Just itemId == (preview updateId =<< formState)
       $with Just UpdateForm{..} <- formState
-         <form .tr .color action=@{UpdateItemR fsUpdateItem}##{toPathPiece fsUpdateItem} method=post enctype=#{fsUpdateEncoding} ##{toPathPiece fsUpdateItem}>
+         <form .tr .color action=@{UpdateItemR fsUpdateId}##{toPathPiece fsUpdateId} method=post enctype=#{fsUpdateEncoding} ##{toPathPiece fsUpdateId}>
            ^{fsUpdateForm}
            <div .td>
              <button type=submit>
diff --git a/templates/referenceListing.hamlet b/templates/referenceListing.hamlet
new file mode 100644
index 0000000..b2b294c
--- /dev/null
+++ b/templates/referenceListing.hamlet
@@ -0,0 +1,17 @@
+<div .table>
+  <div .tr .sepBelow>
+    <div .th>Description
+    <div .th>Actions
+  $if isJust (preview insertForm =<< formState)
+    $with Just InsertForm{..} <- formState
+      <form .tr .sepBelow action=@{ReferenceListingR} method=post enctype=#{fsInsertEncoding}>
+        ^{fsInsertForm}
+        <div .td>
+          <button type=submit>
+            Insert
+  $forall Entity referenceId Reference{..} <- reference
+    <div .tr .color ##{toPathPiece referenceId}>
+      <div .kind>#{referenceKind}
+      <form .td method=post action=@{DeleteRefItemR referenceId}>
+        <button type=submit>
+          Delete
-- 
cgit v1.2.3