From 3d828feba67f21ae62d1e6eb598a22ffaebf1174 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 15 Mar 2017 21:39:15 +0100
Subject: Better ids & warnings

---
 Handler/Common.hs                | 12 ++++++++----
 Handler/InventoryListing.hs      | 15 ++++++++++++++-
 Handler/List.hs                  |  2 +-
 bar.cabal                        |  2 +-
 bar.nix                          | 16 ++++++++--------
 templates/default-layout.cassius | 19 ++++++++++++++++++-
 6 files changed, 50 insertions(+), 16 deletions(-)

diff --git a/Handler/Common.hs b/Handler/Common.hs
index aacab92..c2788e8 100644
--- a/Handler/Common.hs
+++ b/Handler/Common.hs
@@ -14,11 +14,12 @@ module Handler.Common
   , humanId
   ) where
 
-import Import
+import Import hiding ((\\))
 
 import Data.Unique
 
 import qualified Data.Text as Text
+import qualified Data.ByteString.Char8 as CBS
 
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -29,11 +30,14 @@ import Handler.Common.Types
 
 import Text.Julius (RawJS(..))
 
-import qualified Codec.Crockford as Crockford (encode)
 import Database.Persist.Sql (fromSqlKey)
+import qualified Web.Hashids as HID
+import Data.List ((\\))
 
-humanId :: ItemId -> String
-humanId = Crockford.encode . fromSqlKey
+humanId :: ItemId -> Text
+humanId = Text.pack . CBS.unpack . HID.encode ctx . fromIntegral . fromSqlKey
+  where
+    ctx = HID.createHashidsContext "ItemId" 3 $ (['0'..'9'] ++ ['a'..'z']) \\ ['0', 'l', 'v', '2']
 
 dayFormat :: Day -> String
 dayFormat = formatTime defaultTimeLocale "%e. %b %y"
diff --git a/Handler/InventoryListing.hs b/Handler/InventoryListing.hs
index d5252a1..d87512a 100644
--- a/Handler/InventoryListing.hs
+++ b/Handler/InventoryListing.hs
@@ -12,7 +12,20 @@ postInventoryListingR = do
     FormSuccess (Item{..} `WithType` t) -> runDB $ do
       upsertBy (UniqueKind itemNormKind) (Kind itemNormKind t) [ KindType =. t ]
       newItem <- insert Item{..}
-      addMessage "insertSuccess" [hamlet|Inserted new item as #{humanId newItem}|]
+      otherItems <- selectKeysList [ ItemNormKind ==. itemNormKind, ItemId !=. newItem ] []
+      when (not $ null otherItems) . addMessage "insertAmbiguous" $
+        [shamlet|
+                $newline never
+                There are other items of the same kind.
+                <ul>
+                  $forall other <- otherItems
+                    <li .itemId>#{humanId other}
+                |]
+      addMessage "insertSuccess" [shamlet|
+                                         $newline never
+                                         Inserted new item as #
+                                         <span .itemId>#{humanId newItem}
+                                         |]
     FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
     _ -> return ()
 
diff --git a/Handler/List.hs b/Handler/List.hs
index 70f323a..21b735b 100644
--- a/Handler/List.hs
+++ b/Handler/List.hs
@@ -50,7 +50,7 @@ postListR = do
   case printResult of
     FormSuccess pId -> do
       (JobId jId) <- jobCreate (Just pId) $ mkPrintout list
-      addMessage "printSuccess" . toHtml $ "List is printing as job #" <> tshow jId
+      addMessage "printSuccess" [shamlet|List is printing as job ##{jId}|]
     FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
     _ -> return ()
   
diff --git a/bar.cabal b/bar.cabal
index c99c80a..53e4f1e 100644
--- a/bar.cabal
+++ b/bar.cabal
@@ -105,7 +105,7 @@ library
                  , mtl
                  , lens
                  , thermoprint-client
-                 , crockford
+                 , hashids
 
 executable         bar
     if flag(library-only)
diff --git a/bar.nix b/bar.nix
index 00c2a5e..e80d685 100644
--- a/bar.nix
+++ b/bar.nix
@@ -1,12 +1,12 @@
 { mkDerivation, aeson, base, bytestring, case-insensitive
 , classy-prelude, classy-prelude-conduit, classy-prelude-yesod
-, conduit, containers, crockford, data-default, directory
-, fast-logger, file-embed, hjsmin, http-conduit, lens
-, monad-control, monad-logger, mtl, persistent
-, persistent-postgresql, persistent-template, safe, shakespeare
-, stdenv, template-haskell, text, thermoprint-client, time
-, unordered-containers, vector, wai, wai-extra, wai-logger, warp
-, yaml, yesod, yesod-auth, yesod-core, yesod-form, yesod-static
+, conduit, containers, data-default, directory, fast-logger
+, file-embed, hashids, hjsmin, http-conduit, lens, monad-control
+, monad-logger, mtl, persistent, persistent-postgresql
+, persistent-template, safe, shakespeare, stdenv, template-haskell
+, text, thermoprint-client, time, unordered-containers, vector, wai
+, wai-extra, wai-logger, warp, yaml, yesod, yesod-auth, yesod-core
+, yesod-form, yesod-static
 }:
 mkDerivation {
   pname = "bar";
@@ -17,7 +17,7 @@ mkDerivation {
   libraryHaskellDepends = [
     aeson base bytestring case-insensitive classy-prelude
     classy-prelude-conduit classy-prelude-yesod conduit containers
-    crockford data-default directory fast-logger file-embed hjsmin
+    data-default directory fast-logger file-embed hashids hjsmin
     http-conduit lens monad-control monad-logger mtl persistent
     persistent-postgresql persistent-template safe shakespeare
     template-haskell text thermoprint-client time unordered-containers
diff --git a/templates/default-layout.cassius b/templates/default-layout.cassius
index 61a4046..da76e28 100644
--- a/templates/default-layout.cassius
+++ b/templates/default-layout.cassius
@@ -32,11 +32,12 @@
   padding: 0.25em
   color: #aaa
 .itemId
+  font-family: monospace
+div.itemId
   display: table-cell
   text-align: left
   padding: 0.25em
   color: #aaa
-  font-family: monospace
 .table .table .td, .table .table .tc, .table .table .th, .table .table .kind
   padding: 0
 table table td, table table th
@@ -47,10 +48,26 @@ table table td, table table th
   padding: 0
   text-align: center
   font-weight: bold
+  li
+    margin: 0 0 0.5em 0
+  li:last-child
+    margin: 0
   .formError
     color: #800
   .printSuccess, .insertSuccess
     color: #080
+  .insertAmbiguous
+    color: inherit
+    ul
+      list-style-type: none
+      li
+        display: inline
+        margin: 0 0 0 0
+        padding: 0 0 0 0
+      li::before
+        content: ", "
+      li:first-child::before
+        content: ""
 button
   width: 6em
   display: inline-block
-- 
cgit v1.2.3