added supplier management

.dir-locals.el

@@ -1,4 +0,0 @@
-((haskell-mode . ((haskell-indent-spaces . 4)
-                  (haskell-process-use-ghci . t)))
- (hamlet-mode . ((hamlet/basic-offset . 4)
-                 (haskell-process-use-ghci . t))))

.ghci

@@ -1,3 +0,0 @@
-:set -i.:config:dist/build/autogen
-:set -DDEVELOPMENT
-:set -XCPP -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls -XDeriveDataTypeable

Application.hs

@@ -53,6 +53,8 @@ import Handler.CashCheck
 import Handler.Avatar
 import Handler.Barcode
 import Handler.Transfer
+import Handler.Supplier
+import Handler.SupplierActions
 
 -- 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

Foundation.hs

@@ -31,6 +31,7 @@ import Data.List.Split
 import Text.Printf
 
 
+
 prependZero :: Text -> Text
 prependZero t0
  | T.null t1              = t1
@@ -135,6 +136,7 @@ instance Yesod App where
             $(widgetFile "default-layout")
         withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
 
+
     -- The page to be redirected to when authentication is required.
     -- authRoute _ = Just $ AuthR LoginR
 

Handler/Avatar.hs

@@ -141,7 +141,8 @@ getAvatarDeleteR aId = do
     Just _ -> do
       c <- runDB $ selectList [UserAvatar ==. Just aId] []
       d <- runDB $ selectList [BeverageAvatar ==. Just aId] []
-      if null c && null d
+      e <- runDB $ selectList [SupplierAvatar ==. Just aId] []
+      if null c && null d && null e
         then do
           runDB $ delete aId
           setMessageI MsgAvatarDeleted

Handler/Barcode.hs

@@ -53,6 +53,18 @@ getSelectCashBarcodeR = do
     Nothing ->
       redirect SelectCashR
 
+getRestockBarcodeR :: Handler Html
+getRestockBarcodeR = do
+  eub <- handleSelectParam
+  case eub of
+    Just (Right bId) ->
+      redirect $ UpstockR bId
+    Just (Left _) -> do
+      setMessageI MsgBarcodeNotBev
+      redirect RestockR
+    Nothing ->
+      redirect RestockR
+
 handleSelectParam :: Handler (Maybe (Either UserId BeverageId))
 handleSelectParam = do
   c <- lookupGetParam "barcode"

Handler/Modify.hs

@@ -52,6 +52,11 @@ postModifyR bId = do
             , BeverageCorrectedAmount +=. (modBevAmount nBev - beverageAmount bev)
             , BeverageMl =. modBevMl nBev
             , BeverageAvatar =. modBevAvatar nBev
+            , BeverageSupplier =. modBevSupp nBev
+            , BeverageMaxAmount =. modBevMaxAmount nBev
+            , BeveragePerCrate =. modBevPC nBev
+            , BeverageArtNr =. modBevArtNr nBev
+            , BeveragePricePerCrate =. modBevPricePC nBev
             ]
           handleBarcodes (Right bId) (fromMaybe [] $ modBevBarcodes nBev)
           setMessageI MsgEditSuccess
@@ -68,9 +73,14 @@ data ModBev = ModBev
   , modBevPrice :: Int
   , modBevAmount :: Int
   , modBevAlertAmount :: Int
+  , modBevMaxAmount :: Int
   , modBevMl :: Int
+  , modBevPC :: Maybe Int
+  , modBevPricePC :: Maybe Int
   , modBevAvatar :: Maybe AvatarId
   , modBevBarcodes :: Maybe [Text]
+  , modBevSupp :: Maybe SupplierId
+  , modBevArtNr :: Maybe Text
   }
 
 modifyForm :: Beverage -> [Text] -> Form ModBev
@@ -79,13 +89,17 @@ modifyForm bev bs = renderDivs $ ModBev
   <*> areq currencyField (fieldSettingsLabel MsgPrice) (Just $ beveragePrice bev)
   <*> areq amountField (fieldSettingsLabel MsgCurrentStock) (Just $ beverageAmount bev)
   <*> areq amountField (fieldSettingsLabel MsgAnnouncedStock) (Just $ beverageAlertAmount bev)
+  <*> areq amountField (fieldSettingsLabel MsgMaxAmount) (Just $ beverageMaxAmount bev)
   <*> areq volumeField (fieldSettingsLabel MsgVolume) (Just $ beverageMl bev)
+  <*> aopt amountField (fieldSettingsLabel MsgAmountPerCrate) (Just $ beveragePerCrate bev)
+  <*> aopt currencyField (fieldSettingsLabel MsgPricePerCrate) (Just $ beveragePricePerCrate bev)
   <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) (Just $ beverageAvatar bev)
   <*> aopt barcodeField (fieldSettingsLabel MsgBarcodeField) (Just $ Just bs)
+  <*> aopt (selectField sups) (fieldSettingsLabel MsgSelectSupplier) (Just $ beverageSupplier bev)
+  <*> aopt textField (fieldSettingsLabel MsgArtNr) Nothing
   where
-    avatars = do
+    avatars = optionsPersistKey [] [Asc AvatarIdent] avatarIdent
-      ents <- runDB $ selectList [] [Asc AvatarIdent]
+    sups = optionsPersistKey [] [Asc SupplierIdent] supplierIdent
-      optionsPairs $ map (\ent -> (avatarIdent $ entityVal ent, entityKey ent)) ents
 
 getDeleteBeverageR :: BeverageId -> Handler Html
 getDeleteBeverageR bId = do

Handler/Restock.hs

@@ -83,15 +83,19 @@ postNewArticleR = do
       redirect HomeR
 
 newArticleForm :: Form Beverage
-newArticleForm = renderDivs $ Beverage
+newArticleForm = renderDivs $ (\a b c d e f g h i j k-> Beverage a b c d g h i j e f k)
   <$> areq textField (fieldSettingsLabel MsgName) Nothing
   <*> areq currencyField (fieldSettingsLabel MsgPrice) (Just 100)
   <*> areq amountField (fieldSettingsLabel MsgAmount) (Just 0)
   <*> areq amountField (fieldSettingsLabel MsgAmountWarning) (Just 0)
+  <*> areq amountField (fieldSettingsLabel MsgMaxAmount) (Just 200)
+  <*> aopt amountField (fieldSettingsLabel MsgAmountPerCrate) (Just $ Just 20)
   <*> pure 0
   <*> areq volumeField (fieldSettingsLabel MsgVolume) (Just 500)
   <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) Nothing
+  <*> aopt (selectField sups) (fieldSettingsLabel MsgSelectSupplier) Nothing
+  <*> aopt textField (fieldSettingsLabel MsgArtNr) Nothing
+  <*> aopt currencyField (fieldSettingsLabel MsgPricePerCrate) Nothing
   where
-    avatars = do
+    avatars = optionsPersistKey [] [Asc AvatarIdent] avatarIdent
-      ents <- runDB $ selectList [] [Asc AvatarIdent]
+    sups = optionsPersistKey [] [Asc SupplierIdent] supplierIdent
-      optionsPairs $ map (\ent -> (avatarIdent $ entityVal ent, entityKey ent)) ents

Handler/Summary.hs

@@ -47,18 +47,26 @@ data BevStore = BevStore
   { bevStoreIdent :: Text
   , bevStorePrice :: Int
   , bevStoreAmount :: Int
+  , bevStoreMaxAmount :: Int
+  , bevStorePerCrate :: Maybe Int
   , bevStoreAlertAmount :: Int
   , bevStoreMl :: Int
+  , bevStoreArtNr :: Maybe Text
+  , bevStorePricePerCrate :: Maybe Int
   }
 
 instance ToJSON BevStore where
-  toJSON (BevStore ident price amount alertAmount ml) =
+  toJSON (BevStore ident price amount alertAmount maxAmount perCrate ml artNr ppc) =
     object
       [ "name" .= ident
       , "price" .= price
       , "amount" .= amount
       , "alertAt" .= alertAmount
+      , "max" .= maxAmount
+      , "perCrate" .= perCrate
       , "ml" .= ml
+      , "artNr" .= artNr
+      , "pricePerCrate" .= ppc
       ]
 
 instance FromJSON BevStore where
@@ -66,8 +74,12 @@ instance FromJSON BevStore where
     <$> o .: "name"
     <*> o .: "price"
     <*> o .: "amount"
+    <*> o .: "max"
+    <*> o .:? "perCrate"
     <*> o .: "alertAt"
     <*> o .: "ml"
+    <*> o .:? "artNr"
+    <*> o .:? "pricePerCrate"
   -- For errors
   parseJSON _ = mzero
 
@@ -80,8 +92,12 @@ getInventoryJsonR = do
         (beverageIdent bev)
         (beveragePrice bev)
         (beverageAmount bev)
+        (beverageMaxAmount bev)
+        (beveragePerCrate bev)
         (beverageAlertAmount bev)
         (beverageMl bev)
+        (beverageArtNr bev)
+        (beveragePricePerCrate bev)
         ) bevs
 
 getUploadInventoryJsonR :: Handler Html
@@ -99,7 +115,7 @@ postUploadInventoryJsonR = do
         then do
           source <- runResourceT $ fileSource file $$ sinkLbs
           let bevs = fromMaybe [] (decode source :: Maybe [BevStore])
-          I.mapM_ insOrUpd bevs
+          _ <- I.mapM insOrUpd bevs
           setMessageI MsgRestoreSuccess
           redirect HomeR
         else do
@@ -113,19 +129,9 @@ uploadJsonForm :: Form FileInfo
 uploadJsonForm = renderDivs
   $ areq fileField (fieldSettingsLabel MsgSelectFile) Nothing
 
-insOrUpd :: BevStore -> Handler ()
+insOrUpd :: BevStore -> Handler (Entity Beverage)
 insOrUpd bev = do
-  meb <- runDB $ getBy $ UniqueBeverage $ bevStoreIdent bev
+  nbev <- return $ Beverage
-  case meb of
-    Just eb ->
-      runDB $ update (entityKey eb)
-        [ BeveragePrice =. bevStorePrice bev
-        , BeverageAmount =. bevStoreAmount bev
-        , BeverageAlertAmount =. bevStoreAlertAmount bev
-        , BeverageMl =. bevStoreMl bev
-        ]
-    Nothing ->
-      runDB $ insert_ $ Beverage
     (bevStoreIdent bev)
     (bevStorePrice bev)
     (bevStoreAmount bev)
@@ -133,3 +139,19 @@ insOrUpd bev = do
     0
     (bevStoreMl bev)
     Nothing
+    Nothing
+    (bevStoreMaxAmount bev)
+    (bevStorePerCrate bev)
+    (bevStoreArtNr bev)
+    (bevStorePricePerCrate bev)
+  runDB $ upsert nbev
+    [ BeverageIdent =. bevStoreIdent bev
+    , BeveragePrice =. bevStorePrice bev
+    , BeverageAmount =. bevStoreAmount bev
+    , BeverageAlertAmount =. bevStoreAlertAmount bev
+    , BeverageMl =. bevStoreMl bev
+    , BeverageMaxAmount =. bevStoreMaxAmount bev
+    , BeveragePerCrate =. bevStorePerCrate bev
+    , BeverageArtNr =. bevStoreArtNr bev
+    , BeveragePricePerCrate =. bevStorePricePerCrate bev
+    ]

config/models

@@ -6,6 +6,7 @@ User
     avatar AvatarId Maybe
     UniqueUser ident
     deriving Typeable Show
+
 Beverage
     ident Text
     price Int
@@ -14,26 +15,36 @@ Beverage
     correctedAmount Int default=0
     ml Int default=500
     avatar AvatarId Maybe
+    supplier SupplierId Maybe
+    maxAmount Int default=0
+    perCrate Int Maybe
+    artNr Text Maybe
+    pricePerCrate Int Maybe
     UniqueBeverage ident
     deriving Typeable Show
+
 Transaction
     description Text
     amount Int
     time UTCTime
     deriving Typeable Show
+
 Cashier
     balance Int
     created UTCTime default=now()
     deriving Typeable Show
+
 CashCheck
     balance Int
     time UTCTime
     deriving Typeable Show
+
 Avatar
     ident Text
     data ByteString
     hash ByteString default='fill_me!'
     deriving Typeable Show
+
 Barcode
     code Text
     isUser Bool
@@ -42,4 +53,14 @@ Barcode
     UniqueBarcode code
     deriving Show
 
+Supplier
+    ident Text
+    address Textarea
+    tel Text
+    email Text
+    customerId Text
+    avatar AvatarId Maybe
+    UniqueSupplier ident
+    deriving Show
+
  -- By default this file is used in Model.hs (which is imported by Foundation.hs)

config/routes

@@ -34,5 +34,12 @@
 /barcode			HomeBarcodeR		GET
 /user/#UserId/barcode		SelectBarcodeR		GET
 !/user/cash/barcode		SelectCashBarcodeR	GET
+/restock/barcode		RestockBarcodeR		GET
 /user/#UserId/transfer		TransferSelectR		GET
 /user/#UserId/to/#UserId	TransferR		GET POST
+/supply				SupplierR		GET
+/newsupply			NewSupplierR		GET POST
+/supply/#SupplierId		SupplierActionsR	GET
+/supply/#SupplierId/modify	ModifySupplierR		GET POST
+/supply/#SupplierId/digest	SupplierDigestR		GET
+/supply/#SupplierId/delete	DeleteSupplierR		GET

messages/de.msg

@@ -115,3 +115,27 @@ TransferComplete: Transfer abgeschlossen
 TransferError: Fehler beim Transfer
 PreviousPage: vorherige Seite
 NextPage: nächste Seite
+MaxAmount: Maximale Lagermenge
+AmountPerCrate: Anzahl pro Kasten
+SelectSupplier: Lieferanten wählen
+CreateSupplier: Neuen Lieferanten anlegen
+SupplierCreated: Neuer Lieferant wurde erstellt
+SupplierNotCreated: Neuer Lieferant konnte nicht angelegt werden
+Suppliers: Lieferanten
+NewSupplier: Neuer Lieferant
+Address: Adresse
+TelNr: Telefonnummer
+Email: Email
+EditSupplier: Lieferanten bearbeiten
+SupplierUnknown: Dieser Lieferant ist nicht bekannt
+SupplierEdited: Lieferant wurde bearbeitet
+SupplierNotEdited: Lieferant konnte nicht bearbeitet werden
+CreateSupplierDigest: Bestellübersicht für diesen Lieferanten erstellen
+DeleteSupplier: diesen Lieferanten löschen
+SupplierDeleted: Lieferant erfolgreich gelöscht
+SupplierInUseError: Dieser Lieferant wird noch von Produkten benutzt.
+ArtNr: Artikelnummer
+PricePerCrate: Preis Pro Kasten
+CrateCount: AnzahlKästen
+BuyValue: Zahlbetrag
+CustomerId: Kundennummer

templates/default-layout.hamlet

@@ -30,5 +30,7 @@
       <a href=@{SummaryR}>_{MsgSummary}
     <span>
       <a href=@{AvatarR}>_{MsgAvatars}
+    <span>
+      <a href=@{SupplierR}>_{MsgSuppliers}
     <div .right>
       ^{pageBody copyrightWidget}

templates/restock.hamlet

@@ -16,3 +16,6 @@ $forall (Entity bId bev) <- beverages
   <a href=@{NewArticleR}>
     <p>
       _{MsgAddItem}
+
+<form action=@{RestockBarcodeR} method=GET>
+  <input type=hidden #barcodeInput name=barcode>

yammat.cabal

@@ -1,5 +1,5 @@
 name:              yammat
-version:           0.0.1
+version:           0.0.2
 cabal-version:     >= 1.8
 build-type:        Simple
 license:           AGPL-3
@@ -37,9 +37,11 @@ library
                      Handler.Avatar
                      Handler.Barcode
                      Handler.Transfer
+                     Handler.Supplier
+                     Handler.SupplierActions
 
     if flag(dev) || flag(library-only)
-        cpp-options:   -DDEVELOPMENT
+        cpp-options:   -DDEVELOPMENT -DHTTP_CLIENT
         ghc-options:   -Wall -fwarn-tabs -O0
     else
         ghc-options:   -Wall -fwarn-tabs -O2
@@ -78,14 +80,14 @@ library
                  , template-haskell
                  , shakespeare                   >= 2.0        && < 2.1
                  , hjsmin                        >= 0.1        && < 0.2
-                 , monad-control                 >= 0.3        && < 0.4
+                 , monad-control                 >= 0.3        && < 1.1
                  , wai-extra                     >= 3.0        && < 3.1
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.1        && < 2.2
                  , directory                     >= 1.1        && < 1.3
                  , warp                          >= 3.0        && < 3.1
                  , data-default
-                 , aeson                         >= 0.6        && < 0.9
+                 , aeson                         >= 0.6        && < 0.11
                  , conduit                       >= 1.0        && < 2.0
                  , monad-logger                  >= 0.3        && < 0.4
                  , fast-logger                   >= 2.2        && < 2.3
@@ -100,16 +102,22 @@ library
                  , mime-mail
                  , blaze-markup
                  , wai
-                 , blaze-builder                 < 0.4.0.0
+                 , blaze-builder
                  , split
                  , conduit-extra
                  , imagemagick
                  , cryptohash
                  , base64-bytestring
+                 -- for Migrations
+                 , HDBC
+                 , HDBC-postgresql
+                 , bytestring
+                 , cryptohash
+                 , base64-bytestring
 
 executable         yammat
     if flag(library-only)
-        Buildable: True
+        Buildable: False
 
     main-is:           main.hs
     hs-source-dirs:    app
@@ -117,17 +125,17 @@ executable         yammat
 
     ghc-options:       -threaded -O2 -rtsopts -with-rtsopts=-N
 
-executable         Migrate1
+-- executable         Migrate1
-
+-- 
-    main-is:           Migration.hs
+--     main-is:           Migration.hs
-    hs-source-dirs:    Migration/0.0.0-0.0.1
+--     hs-source-dirs:    Migration/0.0.0-0.0.1
-    ghc-options:       -Wall
+--     ghc-options:       -Wall
-    build-depends:     base
+--     build-depends:     base
-                     , HDBC
+--                      , HDBC
-                     , HDBC-postgresql
+--                      , HDBC-postgresql
-                     , bytestring
+--                      , bytestring
-                     , cryptohash
+--                      , cryptohash
-                     , base64-bytestring
+--                      , base64-bytestring
 
 test-suite test
     type:              exitcode-stdio-1.0