summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Application.hs5
-rw-r--r--Foundation.hs11
-rw-r--r--Handler/Common.hs64
-rw-r--r--Handler/Common/Types.hs23
-rw-r--r--Handler/DeleteRefItem.hs10
-rw-r--r--Handler/InventoryListing.hs2
-rw-r--r--Handler/Item.hs10
-rw-r--r--Handler/Kinds.hs8
-rw-r--r--Handler/List.hs71
-rw-r--r--Handler/ReferenceItem.hs25
-rw-r--r--Handler/ReferenceListing.hs27
-rw-r--r--Handler/UpdateItem.hs20
-rw-r--r--Settings.hs7
-rw-r--r--bar.cabal6
-rw-r--r--bar.nix12
-rw-r--r--config/routes6
-rw-r--r--config/settings.yml2
-rw-r--r--shell.nix2
-rw-r--r--stack.yaml2
-rw-r--r--templates/default-layout.cassius44
-rw-r--r--templates/inventoryListing.hamlet4
-rw-r--r--templates/referenceListing.hamlet17
22 files changed, 327 insertions, 51 deletions
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
37import Handler.OpenItem 37import Handler.OpenItem
38import Handler.DeleteItem 38import Handler.DeleteItem
39import Handler.Item 39import Handler.Item
40import Handler.ReferenceListing
41import Handler.ReferenceItem
42import Handler.DeleteRefItem
43import Handler.Kinds
44import Handler.List
40 45
41-- This line actually creates our YesodDispatch instance. It is the second half 46-- This line actually creates our YesodDispatch instance. It is the second half
42-- of the call to mkYesodData which occurs in Foundation.hs. Please see the 47-- 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
78 -- Define the menu items of the header. 78 -- Define the menu items of the header.
79 let menuItems = 79 let menuItems =
80 [ MenuItem "Inventory" InventoryListingR 80 [ MenuItem "Inventory" InventoryListingR
81 , MenuItem "Reference" ReferenceListingR
82 , MenuItem "List" ListR
83 ]
84 currentMenu = listToMaybe
85 [ menuItemLabel
86 | MenuItem{..} <- menuItems
87 , Just menuItemRoute == mCurrentRoute
81 ] 88 ]
82 89
83 -- We break up the default layout into two components: 90 -- We break up the default layout into two components:
@@ -87,6 +94,10 @@ instance Yesod App where
87 -- you to use normal widget features in default-layout. 94 -- you to use normal widget features in default-layout.
88 95
89 pc <- widgetToPageContent $ do 96 pc <- widgetToPageContent $ do
97 setTitle . toHtml . maybe "Bar Inventory" ("Bar Inventory – " <>) $ do
98 cM <- currentMenu
99 guard $ cM /= "Inventory"
100 return cM
90 addScript $ StaticR jquery_js 101 addScript $ StaticR jquery_js
91 addScript $ StaticR webshim_polyfiller_js 102 addScript $ StaticR webshim_polyfiller_js
92 $(widgetFile "default-layout") 103 $(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 @@
3module Handler.Common 3module Handler.Common
4 ( inventoryListing 4 ( inventoryListing
5 , itemForm 5 , itemForm
6 , referenceListing
7 , referenceForm
8 , kinds
6 , InventoryState(..) 9 , InventoryState(..)
10 , ReferenceState(..)
7 , FormState(..) 11 , FormState(..)
12 , HasFormState(..)
8 ) where 13 ) where
9 14
10import Import 15import Import
@@ -25,7 +30,7 @@ itemForm :: Maybe Item -- ^ Update existing item or insert new?
25itemForm proto identView = do 30itemForm proto identView = do
26 today <- utctDay <$> liftIO getCurrentTime 31 today <- utctDay <$> liftIO getCurrentTime
27 32
28 (kindRes, kindView) <- mreq textField "" $ itemKind <$> proto 33 (kindRes, kindWidget) <- kindField $ itemKind <$> proto
29 (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown" 34 (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown"
30 (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never" 35 (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never"
31 (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never" 36 (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never"
@@ -41,7 +46,7 @@ itemForm proto identView = do
41 [whamlet| 46 [whamlet|
42 $newline never 47 $newline never
43 #{identView} 48 #{identView}
44 <div .td>^{fvInput kindView} 49 <div .td>^{kindWidget}
45 <div .td>^{boughtWidget} 50 <div .td>^{boughtWidget}
46 <div .td>^{expiresWidget} 51 <div .td>^{expiresWidget}
47 <div .td>^{openedWidget} 52 <div .td>^{openedWidget}
@@ -73,6 +78,55 @@ itemForm proto identView = do
73 |] 78 |]
74 79
75inventoryListing :: InventoryState -> Widget 80inventoryListing :: InventoryState -> Widget
76inventoryListing InventoryState{..} = do 81inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing")
77 setTitle "Bar Inventory" 82
78 $(widgetFile "inventoryListing") 83referenceForm :: Maybe Reference -- ^ Update existing item or insert new?
84 -> Html -> MForm Handler (FormResult Reference, Widget)
85referenceForm proto identView = do
86 (kindRes, kindWidget) <- kindField $ referenceKind <$> proto
87
88 let referenceRes = do
89 referenceKind <- kindRes
90 return Reference{ referenceNormKind = normalizeKind referenceKind, .. }
91
92 return . (referenceRes, ) $
93 [whamlet|
94 $newline never
95 #{identView}
96 <div .td>^{kindWidget}
97 |]
98
99referenceListing :: ReferenceState -> Widget
100referenceListing ReferenceState{ refFormState = formState, ..} = $(widgetFile "referenceListing")
101
102kindField :: Maybe Text -> MForm Handler (FormResult Text, Widget)
103kindField proto = do
104 optionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique
105
106 let
107 attrs = [ ("list", optionId)
108 , ("autocomplete", "off")
109 ]
110
111 (kindRes, kindView) <- mreq textField ("" { fsAttrs = attrs }) proto
112
113 options <- lift kinds
114
115 return . (kindRes, ) $
116 [whamlet|
117 $newline never
118 ^{fvInput kindView}
119 <datalist ##{optionId}>
120 $forall opt <- options
121 <option value=#{opt}>
122 |]
123
124kinds :: Handler [Text]
125kinds = do
126 stock <- runDB $ selectList [] []
127 reference <- runDB $ selectList [] []
128
129 return $ concat
130 [ [ itemKind | Entity _ Item{..} <- stock ]
131 , [ referenceKind | Entity _ Reference{..} <- reference ]
132 ]
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
8 8
9data InventoryState = InventoryState 9data InventoryState = InventoryState
10 { stock :: [Entity Item] 10 { stock :: [Entity Item]
11 , formState :: Maybe FormState 11 , invFormState :: Maybe (FormState ItemId)
12 } 12 }
13 13
14data FormState = InsertForm 14data ReferenceState = ReferenceState
15 { reference :: [Entity Reference]
16 , refFormState :: Maybe (FormState ReferenceId)
17 }
18
19class HasFormState a where
20 type family UpdateId a :: *
21 formState :: a -> Maybe (FormState (UpdateId a))
22
23instance HasFormState InventoryState where
24 type UpdateId InventoryState = ItemId
25 formState = invFormState
26
27instance HasFormState ReferenceState where
28 type UpdateId ReferenceState = ReferenceId
29 formState = refFormState
30
31data FormState id = InsertForm
15 { fsInsertForm :: Widget 32 { fsInsertForm :: Widget
16 , fsInsertEncoding :: Enctype 33 , fsInsertEncoding :: Enctype
17 } 34 }
18 | UpdateForm 35 | UpdateForm
19 { fsUpdateItem :: ItemId 36 { fsUpdateId :: id
20 , fsUpdateForm :: Widget 37 , fsUpdateForm :: Widget
21 , fsUpdateEncoding :: Enctype 38 , fsUpdateEncoding :: Enctype
22 } 39 }
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 @@
1module Handler.DeleteRefItem where
2
3import Import
4
5postDeleteRefItemR :: ReferenceId -> Handler TypedContent
6postDeleteRefItemR referenceId = do
7 runDB $ delete referenceId
8 selectRep $ do
9 provideJson ()
10 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
18 selectRep $ do 18 selectRep $ do
19 provideJson (stock :: [Entity Item]) 19 provideJson (stock :: [Entity Item])
20 provideRep . defaultLayout $ inventoryListing InventoryState 20 provideRep . defaultLayout $ inventoryListing InventoryState
21 { formState = Just InsertForm{..} 21 { invFormState = Just InsertForm{..}
22 , .. 22 , ..
23 } 23 }
24 24
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
4 4
5getItemR :: ItemId -> Handler TypedContent 5getItemR :: ItemId -> Handler TypedContent
6getItemR itemId = do 6getItemR itemId = do
7 eLookup <- runDB $ fmap (Entity itemId) <$> get itemId 7 entity <- runDB $ Entity itemId <$> get404 itemId
8 case eLookup of 8 selectRep $ do
9 Nothing -> notFound 9 provideJson entity
10 Just entity -> selectRep $ do 10 provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
11 provideJson entity
12 provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
13 11
14putItemR :: ItemId -> Handler Value 12putItemR :: ItemId -> Handler Value
15putItemR itemId = do 13putItemR 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 @@
1module Handler.Kinds where
2
3import Import
4
5import Handler.Common
6
7getKindsR :: Handler Value
8getKindsR = 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 @@
1{-# LANGUAGE ApplicativeDo #-}
2{-# LANGUAGE OverloadedLists #-}
3
4module Handler.List where
5
6import Import
7
8import Data.Set (Set)
9import qualified Data.Set as Set
10
11import Data.Map (Map)
12import qualified Data.Map as Map
13
14import qualified Data.Text as Text
15import qualified Data.Text.Lazy as Lazy.Text
16
17import Database.Persist.Sql (Single(..), rawSql)
18
19import Thermoprint.Client
20
21list :: Handler (Set Text)
22list = do
23 (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)) " []
24 return $ Set.fromList kinds
25
26mkPrintout :: Set Text -> Printout
27mkPrintout list = Printout
28 [ Paragraph
29 [Cooked . either id Line . text . Lazy.Text.fromStrict . Text.unlines . map (" - " <>) $ Set.toAscList list
30 ]
31 ]
32
33getListR, postListR :: Handler TypedContent
34getListR = postListR
35postListR = do
36 Client{..} <- mkClient' . appThermoprintBase . appSettings <$> getYesod
37 let
38 formatPrinter (pId@(PrinterId num), pStatus) =
39 ("Printer #" <> tshow num <> " – " <> tshow pStatus, pId)
40 printers' <- map formatPrinter . Map.toAscList <$> printers
41 list <- list
42
43 ((printResult, printView), printEnc) <- runFormPost . renderDivsNoLabels $ do
44 pId <- case printers' of
45 [(_, pId)] -> pure pId
46 _ -> areq (selectFieldList printers') "Printer" . listToMaybe $ map snd printers'
47 pure pId
48
49 case printResult of
50 FormSuccess pId -> do
51 (JobId jId) <- jobCreate (Just pId) $ mkPrintout list
52 addMessage "printSuccess" . toHtml $ "List is printing as job #" <> tshow jId
53 FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
54 _ -> return ()
55
56 selectRep $ do
57 provideJson list
58 provideRep . defaultLayout $
59 [whamlet|
60 <div .table .main>
61 <div .tr .sepBelow>
62 <div .th>Item
63 $forall item <- Set.toAscList list
64 <div .tr .color>
65 <div .kind>#{item}
66 <form .tr .sepAbove method=post action=@{ListR} enctype=#{printEnc}>
67 <div .td>
68 ^{printView}
69 <button type=submit :Set.null list:disabled>
70 Print
71 |]
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 @@
1module Handler.ReferenceItem where
2
3import Import
4
5getReferenceItemR :: ReferenceId -> Handler TypedContent
6getReferenceItemR referenceId = do
7 entity <- runDB $ Entity referenceId <$> get404 referenceId
8 selectRep $ do
9 provideJson entity
10 provideRep (redirect $ ReferenceListingR :#: referenceId :: Handler Html)
11
12
13putReferenceItemR :: ReferenceId -> Handler Value
14putReferenceItemR referenceId = do
15 Reference{..} <- requireCheckJsonBody
16 returnJson . Entity referenceId =<< runDB
17 (updateGet referenceId [ ReferenceKind =. referenceKind
18 , ReferenceNormKind =. referenceNormKind
19 ])
20
21patchReferenceItemR :: ReferenceId -> Handler Value
22patchReferenceItemR = putReferenceItemR -- Just one field
23
24deleteReferenceItemR :: ReferenceId -> Handler ()
25deleteReferenceItemR = 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 @@
1module Handler.ReferenceListing where
2
3import Import
4
5import Handler.Common
6
7getReferenceListingR, postReferenceListingR :: Handler TypedContent
8getReferenceListingR = postReferenceListingR
9postReferenceListingR = do
10 ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ referenceForm Nothing
11
12 mapM_ (addMessage "formError" . toHtml) =<< case insertResult of
13 FormSuccess newReference -> [] <$ runDB (insert newReference)
14 FormFailure errors -> return errors
15 _ -> return []
16
17 reference <- runDB $ selectList [] [Asc ReferenceKind]
18
19 selectRep $ do
20 provideJson (reference :: [Entity Reference])
21 provideRep . defaultLayout $ referenceListing ReferenceState
22 { refFormState = Just InsertForm{..}
23 , ..
24 }
25
26putReferenceListingR :: Handler Value
27putReferenceListingR = 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
6 6
7getUpdateItemR, postUpdateItemR :: ItemId -> Handler TypedContent 7getUpdateItemR, postUpdateItemR :: ItemId -> Handler TypedContent
8getUpdateItemR = postUpdateItemR 8getUpdateItemR = postUpdateItemR
9postUpdateItemR fsUpdateItem = do 9postUpdateItemR fsUpdateId = do
10 Just entity <- fmap (Entity fsUpdateItem) <$> runDB (get fsUpdateItem) 10 Just entity <- fmap (Entity fsUpdateId) <$> runDB (get fsUpdateId)
11 11
12 ((updateResult, fsUpdateForm), fsUpdateEncoding) <- runFormPost . itemForm . Just $ entityVal entity 12 ((updateResult, fsUpdateForm), fsUpdateEncoding) <- runFormPost . itemForm . Just $ entityVal entity
13 13
14 mapM_ (addMessage "formError" . toHtml) =<< case updateResult of 14 mapM_ (addMessage "formError" . toHtml) =<< case updateResult of
15 FormSuccess Item{..} -> [] <$ runDB (update fsUpdateItem [ ItemKind =. itemKind 15 FormSuccess Item{..} -> [] <$ runDB (update fsUpdateId [ ItemKind =. itemKind
16 , ItemNormKind =. normalizeKind itemKind 16 , ItemNormKind =. normalizeKind itemKind
17 , ItemBought =. itemBought 17 , ItemBought =. itemBought
18 , ItemExpires =. itemExpires 18 , ItemExpires =. itemExpires
19 , ItemOpened =. itemOpened 19 , ItemOpened =. itemOpened
20 ]) 20 ])
21 FormFailure errors -> return errors 21 FormFailure errors -> return errors
22 _ -> return [] 22 _ -> return []
23 23
24 selectRep $ do 24 selectRep $ do
25 provideRep $ case updateResult of 25 provideRep $ case updateResult of
26 FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateItem :: Handler Html 26 FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateId :: Handler Html
27 _ -> do 27 _ -> do
28 (sortOn entityVal -> stock) <- runDB $ selectList [] [] 28 (sortOn entityVal -> stock) <- runDB $ selectList [] []
29 defaultLayout $ inventoryListing InventoryState 29 defaultLayout $ inventoryListing InventoryState
30 { formState = Just UpdateForm{..} 30 { invFormState = Just UpdateForm{..}
31 , .. 31 , ..
32 } 32 }
33 provideJson () 33 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)
19import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, 19import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload,
20 widgetFileReload) 20 widgetFileReload)
21 21
22import Thermoprint.Client (BaseUrl(..), Scheme(..), InvalidBaseUrlException, parseBaseUrl)
23
22#ifdef DEVELOPMENT 24#ifdef DEVELOPMENT
23#define DEV_BOOL True 25#define DEV_BOOL True
24#else 26#else
@@ -47,11 +49,14 @@ data AppSettings = AppSettings
47 -- ^ Should all log messages be displayed? 49 -- ^ Should all log messages be displayed?
48 , appReloadTemplates :: Bool 50 , appReloadTemplates :: Bool
49 -- ^ Use the reload version of templates 51 -- ^ Use the reload version of templates
52
53 , appThermoprintBase :: BaseUrl
50 } 54 }
51 55
52instance FromJSON AppSettings where 56instance FromJSON AppSettings where
53 parseJSON = withObject "AppSettings" $ \o -> do 57 parseJSON = withObject "AppSettings" $ \o -> do
54 let defaultDev = DEV_BOOL 58 let defaultDev = DEV_BOOL
59 parseUrl' = either (fail . show) return . parseBaseUrl
55 appStaticDir <- o .: "static-dir" 60 appStaticDir <- o .: "static-dir"
56 appDatabaseConf <- o .: "database" 61 appDatabaseConf <- o .: "database"
57 appHost <- fromString <$> o .: "host" 62 appHost <- fromString <$> o .: "host"
@@ -62,6 +67,8 @@ instance FromJSON AppSettings where
62 appShouldLogAll <- o .:? "should-log-all" .!= defaultDev 67 appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
63 appReloadTemplates <- o .:? "reload-templates" .!= defaultDev 68 appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
64 69
70 appThermoprintBase <- parseUrl' =<< o .: "thermoprint-url"
71
65 return AppSettings {..} 72 return AppSettings {..}
66 73
67-- | Settings for 'widgetFile', such as which template languages to support and 74-- | 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
27 Handler.OpenItem 27 Handler.OpenItem
28 Handler.DeleteItem 28 Handler.DeleteItem
29 Handler.Item 29 Handler.Item
30 Handler.ReferenceListing
31 Handler.ReferenceItem
32 Handler.DeleteRefItem
33 Handler.Kinds
34 Handler.List
30 35
31 if flag(dev) || flag(library-only) 36 if flag(dev) || flag(library-only)
32 cpp-options: -DDEVELOPMENT 37 cpp-options: -DDEVELOPMENT
@@ -98,6 +103,7 @@ library
98 , wai 103 , wai
99 , mtl 104 , mtl
100 , lens 105 , lens
106 , thermoprint-client
101 107
102executable bar 108executable bar
103 if flag(library-only) 109 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 @@
4, file-embed, hjsmin, http-conduit, lens, monad-control 4, file-embed, hjsmin, http-conduit, lens, monad-control
5, monad-logger, mtl, persistent, persistent-postgresql 5, monad-logger, mtl, persistent, persistent-postgresql
6, persistent-template, safe, shakespeare, stdenv, template-haskell 6, persistent-template, safe, shakespeare, stdenv, template-haskell
7, text, time, unordered-containers, vector, wai, wai-extra 7, text, thermoprint-client, thermoprint-spec, time
8, wai-logger, warp, yaml, yesod, yesod-auth, yesod-core, yesod-form 8, unordered-containers, vector, wai, wai-extra, wai-logger, warp
9, yesod-static 9, yaml, yesod, yesod-auth, yesod-core, yesod-form, yesod-static
10}: 10}:
11mkDerivation { 11mkDerivation {
12 pname = "bar"; 12 pname = "bar";
@@ -20,9 +20,9 @@ mkDerivation {
20 data-default directory fast-logger file-embed hjsmin http-conduit 20 data-default directory fast-logger file-embed hjsmin http-conduit
21 lens monad-control monad-logger mtl persistent 21 lens monad-control monad-logger mtl persistent
22 persistent-postgresql persistent-template safe shakespeare 22 persistent-postgresql persistent-template safe shakespeare
23 template-haskell text time unordered-containers vector wai 23 template-haskell text thermoprint-client thermoprint-spec time
24 wai-extra wai-logger warp yaml yesod yesod-auth yesod-core 24 unordered-containers vector wai wai-extra wai-logger warp yaml
25 yesod-form yesod-static 25 yesod yesod-auth yesod-core yesod-form yesod-static
26 ]; 26 ];
27 executableHaskellDepends = [ base ]; 27 executableHaskellDepends = [ base ];
28 doHaddock = false; 28 doHaddock = false;
diff --git a/config/routes b/config/routes
index 54d6593..08babf4 100644
--- a/config/routes
+++ b/config/routes
@@ -5,3 +5,9 @@
5/inv/#ItemId/open OpenItemR POST 5/inv/#ItemId/open OpenItemR POST
6/inv/#ItemId/delete DeleteItemR POST 6/inv/#ItemId/delete DeleteItemR POST
7/inv/#ItemId ItemR GET PUT PATCH DELETE 7/inv/#ItemId ItemR GET PUT PATCH DELETE
8
9/ref ReferenceListingR GET POST PUT
10/ref/#ReferenceId ReferenceItemR GET PUT PATCH DELETE
11/ref/#ReferenceId/delete DeleteRefItemR POST
12/kinds KindsR GET
13/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"
10# should-log-all: false 10# should-log-all: false
11# reload-templates: false 11# reload-templates: false
12 12
13thermoprint-url: "_env:TPRINT_BASEURL:http://localhost:3000"
14
13database: 15database:
14 user: "_env:PGUSER:bar" 16 user: "_env:PGUSER:bar"
15 password: "_env:PGPASS:" 17 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
10 drv = haskellPackages.callPackage ./bar.nix {}; 10 drv = haskellPackages.callPackage ./bar.nix {};
11in 11in
12 pkgs.stdenv.lib.overrideDerivation drv.env (oldAttrs: { 12 pkgs.stdenv.lib.overrideDerivation drv.env (oldAttrs: {
13 buildInputs = oldAttrs.buildInputs ++ (with pkgs; [ cabal2nix gup haskellPackages.hlint haskellPackages.stack haskellPackages.yesod-bin ]); 13 nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ cabal2nix gup ]) ++ (with haskellPackages; [ hlint stack yesod-bin alex ]);
14 shellHook = '' 14 shellHook = ''
15 ${oldAttrs.shellHook} 15 ${oldAttrs.shellHook}
16 export PROMPT_INFO="${oldAttrs.name}" 16 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 @@
15# resolver: 15# resolver:
16# name: custom-snapshot 16# name: custom-snapshot
17# location: "./custom-snapshot.yaml" 17# location: "./custom-snapshot.yaml"
18resolver: lts-8.5 18resolver: ghc-8.0.2
19 19
20# User packages to be built. 20# User packages to be built.
21# Various formats can be used as shown in the example below. 21# 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 @@
1.main
2 min-width: 20em
1.table 3.table
2 display: table 4 display: table
5 border-collapse: collapse
3.table div 6.table div
4 vertical-align: middle 7 vertical-align: middle
5.td 8.td
@@ -21,25 +24,32 @@
21 display: table-cell 24 display: table-cell
22 text-align: left 25 text-align: left
23 padding: 0.25em 26 padding: 0.25em
27.kind:only-child
28 text-align: center
24.table .table .td, .table .table .tc, .table .table .th, .table .table .kind 29.table .table .td, .table .table .tc, .table .table .th, .table .table .kind
25 padding: 0 30 padding: 0
26.error 31#messages
27 background-color: #fdd
28 text-align: center
29 color: #c00
30 list-style-type: none 32 list-style-type: none
33 margin: 1em auto 1em 0
34 padding: 0
35 text-align: center
36 font-weight: bold
37 .formError
38 color: #800
39 .printSuccess
40 color: #080
31button 41button
32 width: 6em 42 width: 6em
33 display:inline-text 43 display: inline-block
34.day hr 44.day hr
35 width: 2em 45 width: 2em
36 border: 1px solid #ddd 46 border: 1px solid #ddd
37 border-style: solid none solid none 47 border-style: solid none solid none
38.sepBelow > div, .sepAbove > div 48.sepBelow, .sepAbove
39 border: 2px none #ddd 49 border: 2px none #ddd
40.sepBelow > div 50.sepBelow
41 border-bottom-style: solid 51 border-bottom-style: solid
42.sepAbove > div 52.sepAbove
43 border-top-style: solid 53 border-top-style: solid
44.color:nth-child(even) 54.color:nth-child(even)
45 background-color: #f0f0f0 55 background-color: #f0f0f0
@@ -50,26 +60,28 @@ body > div
50.table > h1 60.table > h1
51 display: table-caption 61 display: table-caption
52nav ul 62nav ul
53 display:block 63 display: block
54 text-align: center 64 text-align: center
65 padding: 0
55 li 66 li
56 display:inline-block 67 display: inline-block
57 font-variant: small-caps 68 font-variant: small-caps
58 font-size: 1.5em 69 font-size: 1.5em
59 font-weight: bold 70 font-weight: bold
60 a 71 a
61 text-decoration:none 72 text-decoration: underline
62 color:#aaa 73 color: #aaa
63 a:hover 74 a:hover
64 color:inherit 75 text-decoration: none
65 li.active 76 li.active
66 a 77 a
67 color:inherit 78 color: inherit
79 text-decoration: none
68 li::before 80 li::before
69 content:" | " 81 content: " | "
70 color: #ddd 82 color: #ddd
71 li:first-child::before 83 li:first-child::before
72 content:"" 84 content: ""
73label.checkbox 85label.checkbox
74 input 86 input
75 vertical-align: middle 87 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 @@
13 <button type=submit> 13 <button type=submit>
14 Insert 14 Insert
15 $forall Entity itemId Item{..} <- stock 15 $forall Entity itemId Item{..} <- stock
16 $if Just itemId == (preview updateItem =<< formState) 16 $if Just itemId == (preview updateId =<< formState)
17 $with Just UpdateForm{..} <- formState 17 $with Just UpdateForm{..} <- formState
18 <form .tr .color action=@{UpdateItemR fsUpdateItem}##{toPathPiece fsUpdateItem} method=post enctype=#{fsUpdateEncoding} ##{toPathPiece fsUpdateItem}> 18 <form .tr .color action=@{UpdateItemR fsUpdateId}##{toPathPiece fsUpdateId} method=post enctype=#{fsUpdateEncoding} ##{toPathPiece fsUpdateId}>
19 ^{fsUpdateForm} 19 ^{fsUpdateForm}
20 <div .td> 20 <div .td>
21 <button type=submit> 21 <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 @@
1<div .table>
2 <div .tr .sepBelow>
3 <div .th>Description
4 <div .th>Actions
5 $if isJust (preview insertForm =<< formState)
6 $with Just InsertForm{..} <- formState
7 <form .tr .sepBelow action=@{ReferenceListingR} method=post enctype=#{fsInsertEncoding}>
8 ^{fsInsertForm}
9 <div .td>
10 <button type=submit>
11 Insert
12 $forall Entity referenceId Reference{..} <- reference
13 <div .tr .color ##{toPathPiece referenceId}>
14 <div .kind>#{referenceKind}
15 <form .td method=post action=@{DeleteRefItemR referenceId}>
16 <button type=submit>
17 Delete