summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Handler/Common.hs100
-rw-r--r--Handler/List.hs20
-rw-r--r--Handler/OpenItem.hs2
-rw-r--r--Import/NoFoundation.hs1
-rw-r--r--Model.hs33
-rw-r--r--Model/Types.hs35
-rw-r--r--bar.cabal1
-rw-r--r--config/models6
-rw-r--r--templates/default-layout.cassius2
-rw-r--r--templates/inventoryListing.cassius3
-rw-r--r--templates/inventoryListing.hamlet33
11 files changed, 175 insertions, 61 deletions
diff --git a/Handler/Common.hs b/Handler/Common.hs
index a1ae34b..990732d 100644
--- a/Handler/Common.hs
+++ b/Handler/Common.hs
@@ -28,9 +28,19 @@ import Handler.Common.Types
28 28
29import Text.Julius (RawJS(..)) 29import Text.Julius (RawJS(..))
30 30
31import Data.List.NonEmpty (NonEmpty)
32import Data.Semigroup hiding (First(..))
33import Data.Monoid (First(..))
34
31dayFormat :: Day -> String 35dayFormat :: Day -> String
32dayFormat = formatTime defaultTimeLocale "%e. %b %y" 36dayFormat = formatTime defaultTimeLocale "%e. %b %y"
33 37
38data DayFormConfig = DayFormConfig
39 { dfNever :: Bool
40 , dfUnknown :: Bool
41 , dfKnown :: Bool
42 }
43
34itemForm :: Maybe Item -- ^ Update existing item or insert new? 44itemForm :: Maybe Item -- ^ Update existing item or insert new?
35 -> Html -> MForm Handler (FormResult (WithType Item), Widget) 45 -> Html -> MForm Handler (FormResult (WithType Item), Widget)
36itemForm proto identView = do 46itemForm proto identView = do
@@ -41,12 +51,12 @@ itemForm proto identView = do
41 let kt kWidget tWidget = 51 let kt kWidget tWidget =
42 [whamlet| 52 [whamlet|
43 <div .td>^{kWidget} 53 <div .td>^{kWidget}
44 <div .td>^{tWidget} 54 <div .td>^{tWidget}
45 |] 55 |]
46 ((kindRes, typeRes), typedKindWidget) <- typedKindField kt ((itemKind <$> proto), t) 56 ((kindRes, typeRes), typedKindWidget) <- typedKindField kt ((itemKind <$> proto), t)
47 (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown" 57 (boughtRes, boughtWidget) <- dayForm (Just . fromMaybe (DateKnown today) $ itemBought <$> proto) $ DayFormConfig False True True
48 (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never" 58 (expiresRes, expiresWidget) <- dayForm (itemExpires <$> proto) $ DayFormConfig True False True
49 (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never" 59 (openedRes, openedWidget) <- dayForm (itemOpened <$> proto) $ DayFormConfig True True True
50 60
51 let itemRes = do 61 let itemRes = do
52 itemKind <- kindRes 62 itemKind <- kindRes
@@ -66,33 +76,79 @@ itemForm proto identView = do
66 <div .td>^{openedWidget} 76 <div .td>^{openedWidget}
67 |] 77 |]
68 where 78 where
69 dayForm :: Maybe (Maybe Day) -> String -> MForm Handler (FormResult (Maybe Day), Widget) 79 dayForm :: Maybe ItemDate -> DayFormConfig -> MForm Handler (FormResult ItemDate, Widget)
70 dayForm proto label = do 80 dayForm proto DayFormConfig{..} = do
71 today <- utctDay <$> liftIO getCurrentTime 81 today <- utctDay <$> liftIO getCurrentTime
72 82
73 checkboxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique 83 let mWhen = bool (Nothing <$) (fmap Just)
84
85 neverBoxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique
86 unknownBoxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique
87 groupId <- ("dateGroup" <>) . show . hashUnique <$> liftIO newUnique
74 88
75 (fmap (fromMaybe False) -> isNothingRes, isNothingView) <- 89 dNever <- mWhen dfNever $
76 mopt checkBoxField ("" { fsId = Just $ Text.pack checkboxId }) . Just . Just . fromMaybe True $ fmap isNothing proto 90 mopt checkBoxField ("" { fsId = Just $ Text.pack neverBoxId }) . Just . Just . fromMaybe True $ fmap isNever proto
77 (dayRes, dayView) <- 91 dUnknown <- mWhen dfUnknown $
78 mreq dayField "" . Just . fromMaybe today $ join proto 92 mopt checkBoxField ("" { fsId = Just $ Text.pack unknownBoxId }) . Just . Just . fromMaybe False $ fmap isUnknown proto
93 dDay <- mWhen dfKnown $
94 mopt dayField "" . Just . Just $ case proto of
95 Just (DateKnown d) -> d
96 _ -> today
79 97
80 let res = (bool Just (const Nothing) <$> isNothingRes) <*> dayRes 98 let res = resFromMaybe . fromMaybe FormMissing . fmap (fmap getFirst) $ mconcat
99 [ fmap (fmap (First . bool Nothing (Just DateNever) . fromMaybe False) . fst) dNever
100 , fmap (fmap (First . bool Nothing (Just DateUnknown) . fromMaybe False) . fst) dUnknown
101 , fmap (fmap (First . fmap DateKnown) . fst) dDay
102 ]
103 resFromMaybe (FormSuccess Nothing) = FormFailure ["Missing required information"]
104 resFromMaybe (FormSuccess (Just x)) = FormSuccess x
105 resFromMaybe FormMissing = FormMissing
106 resFromMaybe (FormFailure es) = FormFailure es
81 return . (res, ) $ do 107 return . (res, ) $ do
108 toWidget $
109 [julius|
110 $(function () {
111 var updateInput = function() {
112 $('##{rawJS groupId} :input').filter(':not(:checkbox)').prop("disabled", $('##{rawJS groupId} :checkbox').filter(':checked').length > 0);
113 };
114
115 $('##{rawJS groupId} :checkbox').change(function() {
116 if (this.checked) {
117 $('##{rawJS groupId} :checkbox').not(this).prop('checked', false);
118 }
119 updateInput();
120 });
121
122 updateInput();
123 });
124 |]
125 let width = length $ (filter id [ isJust dNever, isJust dUnknown ] :: [Bool])
82 [whamlet| 126 [whamlet|
83 $newline never 127 $newline never
84 <div .table> 128 <table ##{groupId} .dayField>
85 <div .tr> 129 <tr>
86 <label for=#{checkboxId} .checkbox .td> 130 $maybe (_, isNeverView) <- dNever
87 ^{fvInput isNothingView} 131 <td>
88 <span> 132 <label for=#{neverBoxId} .checkbox>
89 #{label} 133 ^{fvInput isNeverView}
90 <div .tr> 134 <span>
91 <div .td .dayInput>^{fvInput dayView} 135 Never
136 $maybe (_, isUnknownView) <- dUnknown
137 <td>
138 <label for=#{unknownBoxId} .checkbox>
139 ^{fvInput isUnknownView}
140 <span>
141 Unknown
142 $maybe (_, dayView) <- dDay
143 <tr>
144 <td .dayInput :width > 0:colspan=#{width}>
145 ^{fvInput dayView}
92 |] 146 |]
93 147
94inventoryListing :: InventoryState -> Widget 148inventoryListing :: InventoryState -> Widget
95inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing") 149inventoryListing InventoryState{ invFormState = formState, ..} = do
150 today <- liftIO $ utctDay <$> getCurrentTime
151 $(widgetFile "inventoryListing")
96 152
97referenceForm :: Maybe Reference -- ^ Update existing item or insert new? 153referenceForm :: Maybe Reference -- ^ Update existing item or insert new?
98 -> Html -> MForm Handler (FormResult (WithType Reference), Widget) 154 -> Html -> MForm Handler (FormResult (WithType Reference), Widget)
@@ -188,7 +244,7 @@ kinds = do
188 stock <- runDB $ selectList [] [] 244 stock <- runDB $ selectList [] []
189 reference <- runDB $ selectList [] [] 245 reference <- runDB $ selectList [] []
190 246
191 return . Set.fromList $ concat 247 return . Set.fromList $ (concat :: [[a]] -> [a])
192 [ [ itemKind | Entity _ Item{..} <- stock ] 248 [ [ itemKind | Entity _ Item{..} <- stock ]
193 , [ referenceKind | Entity _ Reference{..} <- reference ] 249 , [ referenceKind | Entity _ Reference{..} <- reference ]
194 ] 250 ]
diff --git a/Handler/List.hs b/Handler/List.hs
index 70f323a..4209651 100644
--- a/Handler/List.hs
+++ b/Handler/List.hs
@@ -19,9 +19,23 @@ import Database.Persist.Sql (Single(..), rawSql)
19import Thermoprint.Client 19import Thermoprint.Client
20 20
21list :: Handler (Set (WithType Text)) 21list :: Handler (Set (WithType Text))
22list = do 22list = runDB $ do
23 (map (uncurry WithType . bimap unSingle unSingle) -> kinds) <- runDB $ rawSql "select reference.kind, kind.type from reference,kind where (not exists (select * from item where COALESCE(item.expires >= CURRENT_DATE, TRUE) and (item.norm_kind = reference.norm_kind))) and (reference.norm_kind = kind.norm_kind)" [] 23 today <- liftIO $ utctDay <$> getCurrentTime
24 return $ Set.fromList kinds 24
25 items <- map entityVal <$> selectList [] []
26 references <- Set.fromList <$> (withTypes . fmap entityVal =<< selectList [] [])
27
28 let
29 references' = Set.filter (isNothing . flip find items . matches) references
30 matches (Reference{..} `WithType` _) Item{..}
31 | today `isBefore` itemExpires = itemNormKind == referenceNormKind
32 | otherwise = False
33
34 isBefore _ DateNever = True
35 isBefore _ DateUnknown = False
36 isBefore d1 (DateKnown d2) = d1 < d2
37
38 return $ Set.map (fmap referenceKind) references'
25 39
26mkPrintout :: Set (WithType Text) -> Printout 40mkPrintout :: Set (WithType Text) -> Printout
27mkPrintout list = Printout ps 41mkPrintout list = Printout ps
diff --git a/Handler/OpenItem.hs b/Handler/OpenItem.hs
index 468c6ec..3b1dfeb 100644
--- a/Handler/OpenItem.hs
+++ b/Handler/OpenItem.hs
@@ -5,7 +5,7 @@ import Import
5postOpenItemR :: ItemId -> Handler TypedContent 5postOpenItemR :: ItemId -> Handler TypedContent
6postOpenItemR itemId = do 6postOpenItemR itemId = do
7 today <- utctDay <$> liftIO getCurrentTime 7 today <- utctDay <$> liftIO getCurrentTime
8 result <- fmap (Entity itemId) . runDB $ updateGet itemId [ ItemOpened =. Just today 8 result <- fmap (Entity itemId) . runDB $ updateGet itemId [ ItemOpened =. DateKnown today
9 ] 9 ]
10 selectRep $ do 10 selectRep $ do
11 provideJson result 11 provideJson result
diff --git a/Import/NoFoundation.hs b/Import/NoFoundation.hs
index 6872d0a..1a5b107 100644
--- a/Import/NoFoundation.hs
+++ b/Import/NoFoundation.hs
@@ -5,6 +5,7 @@ module Import.NoFoundation
5 5
6import ClassyPrelude.Yesod as Import 6import ClassyPrelude.Yesod as Import
7import Model as Import 7import Model as Import
8import Model.Types as Import
8import Settings as Import 9import Settings as Import
9import Settings.StaticFiles as Import 10import Settings.StaticFiles as Import
10import Yesod.Auth as Import 11import Yesod.Auth as Import
diff --git a/Model.hs b/Model.hs
index 90f5904..8778111 100644
--- a/Model.hs
+++ b/Model.hs
@@ -1,4 +1,5 @@
1{-# LANGUAGE FlexibleInstances #-} 1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE DeriveFunctor #-}
2 3
3module Model where 4module Model where
4 5
@@ -18,6 +19,8 @@ import qualified Data.HashMap.Lazy as HashMap
18import Data.Aeson 19import Data.Aeson
19import Data.Aeson.Types (Parser, Value(..)) 20import Data.Aeson.Types (Parser, Value(..))
20 21
22import Model.Types
23
21-- You can define all of your database entities in the entities file. 24-- You can define all of your database entities in the entities file.
22-- You can find more information on persistent and how to declare entities 25-- You can find more information on persistent and how to declare entities
23-- at: 26-- at:
@@ -68,32 +71,28 @@ withTypes vals = do
68instance Ord Item where 71instance Ord Item where
69 x `compare` y = mconcat cmprs 72 x `compare` y = mconcat cmprs
70 where 73 where
71 cmprs = [ itemOpened x `compareM` itemOpened y 74 cmprs = [ itemOpened x `compare` itemOpened y
72 , itemExpires x `compareM` itemExpires y 75 , itemExpires x `compare` itemExpires y
73 , itemKind x `compare` itemKind y 76 , itemKind x `compare` itemKind y
74 , itemBought x `compare` itemBought y 77 , itemBought x `compare` itemBought y
75 ] 78 ]
76 79
77 compareM (Just _) Nothing = LT
78 compareM Nothing (Just _) = GT
79 compareM (Just a) (Just b) = compare a b
80 compareM _ _ = EQ
81
82instance ToJSON Item where 80instance ToJSON Item where
83 toJSON Item{..} = object $ 81 toJSON Item{..} = object $
84 [ "kind" .= itemKind 82 [ "kind" .= itemKind
85 ] ++ maybe [] (\x -> ["bought" .= x]) itemBought 83 , "bought" .= itemBought
86 ++ maybe [] (\x -> ["expires" .= x]) itemExpires 84 , "expires" .= itemExpires
87 ++ maybe [] (\x -> ["opened" .= x]) itemOpened 85 , "opened" .= itemOpened
86 ]
88 87
89instance FromJSON Item where 88instance FromJSON Item where
90 parseJSON = withObject "Item" $ \obj -> do 89 parseJSON = withObject "Item" $ \obj -> do
91 itemKind <- obj .: "kind" 90 itemKind <- obj .: "kind"
92 let 91 let
93 itemNormKind = normalizeKind itemKind 92 itemNormKind = normalizeKind itemKind
94 itemBought <- obj .:? "bought" 93 itemBought <- maybe DateUnknown DateKnown <$> obj .:? "bought"
95 itemExpires <- obj .:? "expires" 94 itemExpires <- maybe DateNever DateKnown <$> obj .:? "expires"
96 itemOpened <- obj .:? "opened" 95 itemOpened <- obj .: "opened"
97 return Item{..} 96 return Item{..}
98 97
99instance ToJSON (Entity Item) where 98instance ToJSON (Entity Item) where
@@ -122,9 +121,9 @@ normalizeKind = Text.strip . Text.toCaseFold
122 121
123data ItemDiff = DiffKind Text 122data ItemDiff = DiffKind Text
124 | DiffType Text 123 | DiffType Text
125 | DiffBought (Maybe Day) 124 | DiffBought ItemDate
126 | DiffExpires (Maybe Day) 125 | DiffExpires ItemDate
127 | DiffOpened (Maybe Day) 126 | DiffOpened ItemDate
128 127
129newtype ItemDiffs = ItemDiffs [ItemDiff] 128newtype ItemDiffs = ItemDiffs [ItemDiff]
130 129
@@ -149,7 +148,7 @@ toUpdate (ItemDiffs ds) = mconcat $ do
149 DiffOpened d -> (, []) [ ItemOpened =. d ] 148 DiffOpened d -> (, []) [ ItemOpened =. d ]
150 149
151data WithType a = WithType { typedVal :: a, valType :: Text } 150data WithType a = WithType { typedVal :: a, valType :: Text }
152 deriving (Eq, Ord, Show) 151 deriving (Eq, Ord, Show, Functor)
153 152
154typeToJSON :: ToJSON a 153typeToJSON :: ToJSON a
155 => Text -- ^ Key for value, if needed 154 => Text -- ^ Key for value, if needed
diff --git a/Model/Types.hs b/Model/Types.hs
new file mode 100644
index 0000000..61bebfd
--- /dev/null
+++ b/Model/Types.hs
@@ -0,0 +1,35 @@
1{-# LANGUAGE DeriveGeneric #-}
2
3module Model.Types
4 ( ItemDate(..)
5 , isNever, isUnknown, isKnown
6 ) where
7
8import ClassyPrelude.Yesod
9
10data ItemDate = DateUnknown | DateKnown Day | DateNever
11 deriving (Eq, Ord, Show, Read, Generic)
12
13isNever, isUnknown, isKnown :: ItemDate -> Bool
14isNever DateNever = True
15isNever _ = False
16isUnknown DateUnknown = True
17isUnknown _ = False
18isKnown (DateKnown _) = True
19isKnown _ = False
20
21unknownVerb :: IsString a => a
22unknownVerb = "unknown"
23
24instance ToJSON ItemDate where
25 toJSON DateNever = Null
26 toJSON DateUnknown = String unknownVerb
27 toJSON (DateKnown d) = toJSON d
28instance FromJSON ItemDate where
29 parseJSON Null = pure DateNever
30 parseJSON v@(String inp)
31 | unknownVerb == inp = pure DateUnknown
32 | otherwise = DateKnown <$> parseJSON v
33 parseJSON v = DateKnown <$> parseJSON v
34
35derivePersistFieldJSON "ItemDate"
diff --git a/bar.cabal b/bar.cabal
index 5003000..5605d97 100644
--- a/bar.cabal
+++ b/bar.cabal
@@ -18,6 +18,7 @@ library
18 Import 18 Import
19 Import.NoFoundation 19 Import.NoFoundation
20 Model 20 Model
21 Model.Types
21 Settings 22 Settings
22 Settings.StaticFiles 23 Settings.StaticFiles
23 Handler.Common 24 Handler.Common
diff --git a/config/models b/config/models
index 16b4ce0..8aebc5b 100644
--- a/config/models
+++ b/config/models
@@ -1,9 +1,9 @@
1Item 1Item
2 kind Text 2 kind Text
3 normKind Text 3 normKind Text
4 bought Day Maybe 4 bought ItemDate
5 expires Day Maybe 5 expires ItemDate
6 opened Day Maybe 6 opened ItemDate
7 Foreign Kind fkType normKind 7 Foreign Kind fkType normKind
8 deriving Show Eq 8 deriving Show Eq
9Reference 9Reference
diff --git a/templates/default-layout.cassius b/templates/default-layout.cassius
index bd76a01..50aab3f 100644
--- a/templates/default-layout.cassius
+++ b/templates/default-layout.cassius
@@ -33,7 +33,7 @@
33 color: #aaa 33 color: #aaa
34.table .table .td, .table .table .tc, .table .table .th, .table .table .kind 34.table .table .td, .table .table .tc, .table .table .th, .table .table .kind
35 padding: 0 35 padding: 0
36table table td, table table th 36table table td, table table th, .table table td, .table table th
37 padding: 0 37 padding: 0
38#messages 38#messages
39 list-style-type: none 39 list-style-type: none
diff --git a/templates/inventoryListing.cassius b/templates/inventoryListing.cassius
new file mode 100644
index 0000000..9a7459e
--- /dev/null
+++ b/templates/inventoryListing.cassius
@@ -0,0 +1,3 @@
1.expired
2 color: #800
3 font-weight: bold \ No newline at end of file
diff --git a/templates/inventoryListing.hamlet b/templates/inventoryListing.hamlet
index 3be43db..39758bb 100644
--- a/templates/inventoryListing.hamlet
+++ b/templates/inventoryListing.hamlet
@@ -26,22 +26,27 @@
26 <div .kind>#{itemKind} 26 <div .kind>#{itemKind}
27 <div .type>#{itemType} 27 <div .type>#{itemType}
28 <div .td .day> 28 <div .td .day>
29 $maybe bought <- itemBought 29 $case itemBought
30 #{dayFormat bought} 30 $of DateUnknown
31 $nothing 31 <hr>
32 <hr> 32 $of DateKnown d
33 #{dayFormat d}
33 <div .td .day> 34 <div .td .day>
34 $maybe expires <- itemExpires 35 $case itemExpires
35 #{dayFormat expires} 36 $of DateNever
36 $nothing 37 <hr>
37 <hr> 38 $of DateKnown d
39 <span :d < today:.expired>#{dayFormat d}
38 <div .td .day> 40 <div .td .day>
39 $maybe opened <- itemOpened 41 $case itemOpened
40 #{dayFormat opened} 42 $of DateKnown d
41 $nothing 43 #{dayFormat d}
42 <form method=post action=@{OpenItemR itemId}> 44 $of DateUnknown
43 <button type=submit> 45 Yes
44 Open 46 $of DateNever
47 <form method=post action=@{OpenItemR itemId}>
48 <button type=submit>
49 Open
45 <div .td> 50 <div .td>
46 <form method=get action=@{UpdateItemR itemId}##{toPathPiece itemId}> 51 <form method=get action=@{UpdateItemR itemId}##{toPathPiece itemId}>
47 <button type=submit> 52 <button type=submit>