diff options
-rw-r--r-- | Application.hs | 5 | ||||
-rw-r--r-- | Foundation.hs | 11 | ||||
-rw-r--r-- | Handler/Common.hs | 64 | ||||
-rw-r--r-- | Handler/Common/Types.hs | 23 | ||||
-rw-r--r-- | Handler/DeleteRefItem.hs | 10 | ||||
-rw-r--r-- | Handler/InventoryListing.hs | 2 | ||||
-rw-r--r-- | Handler/Item.hs | 10 | ||||
-rw-r--r-- | Handler/Kinds.hs | 8 | ||||
-rw-r--r-- | Handler/List.hs | 71 | ||||
-rw-r--r-- | Handler/ReferenceItem.hs | 25 | ||||
-rw-r--r-- | Handler/ReferenceListing.hs | 27 | ||||
-rw-r--r-- | Handler/UpdateItem.hs | 20 | ||||
-rw-r--r-- | Settings.hs | 7 | ||||
-rw-r--r-- | bar.cabal | 6 | ||||
-rw-r--r-- | bar.nix | 12 | ||||
-rw-r--r-- | config/routes | 6 | ||||
-rw-r--r-- | config/settings.yml | 2 | ||||
-rw-r--r-- | shell.nix | 2 | ||||
-rw-r--r-- | stack.yaml | 2 | ||||
-rw-r--r-- | templates/default-layout.cassius | 44 | ||||
-rw-r--r-- | templates/inventoryListing.hamlet | 4 | ||||
-rw-r--r-- | templates/referenceListing.hamlet | 17 |
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 | |||
37 | import Handler.OpenItem | 37 | import Handler.OpenItem |
38 | import Handler.DeleteItem | 38 | import Handler.DeleteItem |
39 | import Handler.Item | 39 | import Handler.Item |
40 | import Handler.ReferenceListing | ||
41 | import Handler.ReferenceItem | ||
42 | import Handler.DeleteRefItem | ||
43 | import Handler.Kinds | ||
44 | import 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 @@ | |||
3 | module Handler.Common | 3 | module 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 | ||
10 | import Import | 15 | import Import |
@@ -25,7 +30,7 @@ itemForm :: Maybe Item -- ^ Update existing item or insert new? | |||
25 | itemForm proto identView = do | 30 | itemForm 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 | ||
75 | inventoryListing :: InventoryState -> Widget | 80 | inventoryListing :: InventoryState -> Widget |
76 | inventoryListing InventoryState{..} = do | 81 | inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing") |
77 | setTitle "Bar Inventory" | 82 | |
78 | $(widgetFile "inventoryListing") | 83 | referenceForm :: Maybe Reference -- ^ Update existing item or insert new? |
84 | -> Html -> MForm Handler (FormResult Reference, Widget) | ||
85 | referenceForm 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 | |||
99 | referenceListing :: ReferenceState -> Widget | ||
100 | referenceListing ReferenceState{ refFormState = formState, ..} = $(widgetFile "referenceListing") | ||
101 | |||
102 | kindField :: Maybe Text -> MForm Handler (FormResult Text, Widget) | ||
103 | kindField 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 | |||
124 | kinds :: Handler [Text] | ||
125 | kinds = 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 | ||
9 | data InventoryState = InventoryState | 9 | data InventoryState = InventoryState |
10 | { stock :: [Entity Item] | 10 | { stock :: [Entity Item] |
11 | , formState :: Maybe FormState | 11 | , invFormState :: Maybe (FormState ItemId) |
12 | } | 12 | } |
13 | 13 | ||
14 | data FormState = InsertForm | 14 | data ReferenceState = ReferenceState |
15 | { reference :: [Entity Reference] | ||
16 | , refFormState :: Maybe (FormState ReferenceId) | ||
17 | } | ||
18 | |||
19 | class HasFormState a where | ||
20 | type family UpdateId a :: * | ||
21 | formState :: a -> Maybe (FormState (UpdateId a)) | ||
22 | |||
23 | instance HasFormState InventoryState where | ||
24 | type UpdateId InventoryState = ItemId | ||
25 | formState = invFormState | ||
26 | |||
27 | instance HasFormState ReferenceState where | ||
28 | type UpdateId ReferenceState = ReferenceId | ||
29 | formState = refFormState | ||
30 | |||
31 | data 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 @@ | |||
1 | module Handler.DeleteRefItem where | ||
2 | |||
3 | import Import | ||
4 | |||
5 | postDeleteRefItemR :: ReferenceId -> Handler TypedContent | ||
6 | postDeleteRefItemR 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 | ||
5 | getItemR :: ItemId -> Handler TypedContent | 5 | getItemR :: ItemId -> Handler TypedContent |
6 | getItemR itemId = do | 6 | getItemR 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 | ||
14 | putItemR :: ItemId -> Handler Value | 12 | putItemR :: ItemId -> Handler Value |
15 | putItemR itemId = do | 13 | 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 @@ | |||
1 | module Handler.Kinds where | ||
2 | |||
3 | import Import | ||
4 | |||
5 | import Handler.Common | ||
6 | |||
7 | getKindsR :: Handler Value | ||
8 | 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 @@ | |||
1 | {-# LANGUAGE ApplicativeDo #-} | ||
2 | {-# LANGUAGE OverloadedLists #-} | ||
3 | |||
4 | module Handler.List where | ||
5 | |||
6 | import Import | ||
7 | |||
8 | import Data.Set (Set) | ||
9 | import qualified Data.Set as Set | ||
10 | |||
11 | import Data.Map (Map) | ||
12 | import qualified Data.Map as Map | ||
13 | |||
14 | import qualified Data.Text as Text | ||
15 | import qualified Data.Text.Lazy as Lazy.Text | ||
16 | |||
17 | import Database.Persist.Sql (Single(..), rawSql) | ||
18 | |||
19 | import Thermoprint.Client | ||
20 | |||
21 | list :: Handler (Set Text) | ||
22 | list = 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 | |||
26 | mkPrintout :: Set Text -> Printout | ||
27 | mkPrintout list = Printout | ||
28 | [ Paragraph | ||
29 | [Cooked . either id Line . text . Lazy.Text.fromStrict . Text.unlines . map (" - " <>) $ Set.toAscList list | ||
30 | ] | ||
31 | ] | ||
32 | |||
33 | getListR, postListR :: Handler TypedContent | ||
34 | getListR = postListR | ||
35 | postListR = 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 | |||
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 @@ | |||
1 | module Handler.ReferenceItem where | ||
2 | |||
3 | import Import | ||
4 | |||
5 | getReferenceItemR :: ReferenceId -> Handler TypedContent | ||
6 | getReferenceItemR referenceId = do | ||
7 | entity <- runDB $ Entity referenceId <$> get404 referenceId | ||
8 | selectRep $ do | ||
9 | provideJson entity | ||
10 | provideRep (redirect $ ReferenceListingR :#: referenceId :: Handler Html) | ||
11 | |||
12 | |||
13 | putReferenceItemR :: ReferenceId -> Handler Value | ||
14 | putReferenceItemR referenceId = do | ||
15 | Reference{..} <- requireCheckJsonBody | ||
16 | returnJson . Entity referenceId =<< runDB | ||
17 | (updateGet referenceId [ ReferenceKind =. referenceKind | ||
18 | , ReferenceNormKind =. referenceNormKind | ||
19 | ]) | ||
20 | |||
21 | patchReferenceItemR :: ReferenceId -> Handler Value | ||
22 | patchReferenceItemR = putReferenceItemR -- Just one field | ||
23 | |||
24 | deleteReferenceItemR :: ReferenceId -> Handler () | ||
25 | 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 @@ | |||
1 | module Handler.ReferenceListing where | ||
2 | |||
3 | import Import | ||
4 | |||
5 | import Handler.Common | ||
6 | |||
7 | getReferenceListingR, postReferenceListingR :: Handler TypedContent | ||
8 | getReferenceListingR = postReferenceListingR | ||
9 | postReferenceListingR = 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 | |||
26 | putReferenceListingR :: Handler Value | ||
27 | 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 | |||
6 | 6 | ||
7 | getUpdateItemR, postUpdateItemR :: ItemId -> Handler TypedContent | 7 | getUpdateItemR, postUpdateItemR :: ItemId -> Handler TypedContent |
8 | getUpdateItemR = postUpdateItemR | 8 | getUpdateItemR = postUpdateItemR |
9 | postUpdateItemR fsUpdateItem = do | 9 | postUpdateItemR 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) | |||
19 | import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, | 19 | import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, |
20 | widgetFileReload) | 20 | widgetFileReload) |
21 | 21 | ||
22 | import 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 | ||
52 | instance FromJSON AppSettings where | 56 | instance 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 |
@@ -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 | ||
102 | executable bar | 108 | executable bar |
103 | if flag(library-only) | 109 | if flag(library-only) |
@@ -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 | }: |
11 | mkDerivation { | 11 | mkDerivation { |
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 | ||
13 | thermoprint-url: "_env:TPRINT_BASEURL:http://localhost:3000" | ||
14 | |||
13 | database: | 15 | database: |
14 | user: "_env:PGUSER:bar" | 16 | user: "_env:PGUSER:bar" |
15 | password: "_env:PGPASS:" | 17 | password: "_env:PGPASS:" |
@@ -10,7 +10,7 @@ let | |||
10 | drv = haskellPackages.callPackage ./bar.nix {}; | 10 | drv = haskellPackages.callPackage ./bar.nix {}; |
11 | in | 11 | in |
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}" |
@@ -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" |
18 | resolver: lts-8.5 | 18 | resolver: 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 | ||
31 | button | 41 | button |
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 |
52 | nav ul | 62 | nav 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: "" |
73 | label.checkbox | 85 | label.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 | ||