diff options
Diffstat (limited to 'bragi')
-rwxr-xr-x | bragi/bar.hs | 396 |
1 files changed, 385 insertions, 11 deletions
diff --git a/bragi/bar.hs b/bragi/bar.hs index 067e5af4..64650779 100755 --- a/bragi/bar.hs +++ b/bragi/bar.hs | |||
@@ -12,14 +12,22 @@ | |||
12 | {-# LANGUAGE TemplateHaskell #-} | 12 | {-# LANGUAGE TemplateHaskell #-} |
13 | {-# LANGUAGE TypeFamilies #-} | 13 | {-# LANGUAGE TypeFamilies #-} |
14 | {-# LANGUAGE FlexibleInstances #-} | 14 | {-# LANGUAGE FlexibleInstances #-} |
15 | {-# LANGUAGE ViewPatterns #-} | ||
16 | {-# LANGUAGE TupleSections #-} | ||
17 | {-# LANGUAGE ApplicativeDo #-} | ||
15 | 18 | ||
16 | 19 | ||
17 | import Yesod | 20 | import Yesod |
18 | import Database.Persist.Postgresql | 21 | import Database.Persist.Postgresql |
22 | |||
19 | import Control.Monad.Logger (runStderrLoggingT) | 23 | import Control.Monad.Logger (runStderrLoggingT) |
20 | import Control.Monad.Reader | 24 | import Control.Monad.Reader |
25 | import Control.Monad.Writer | ||
26 | import Control.Monad.Trans.Maybe | ||
21 | 27 | ||
28 | import Data.Time.Clock | ||
22 | import Data.Time.Calendar | 29 | import Data.Time.Calendar |
30 | import Data.Time.Format | ||
23 | 31 | ||
24 | import Data.Text (Text) | 32 | import Data.Text (Text) |
25 | import qualified Data.Text as Text | 33 | import qualified Data.Text as Text |
@@ -27,7 +35,17 @@ import qualified Data.Text as Text | |||
27 | import Data.Map.Lazy (Map) | 35 | import Data.Map.Lazy (Map) |
28 | import qualified Data.Map.Lazy as Map | 36 | import qualified Data.Map.Lazy as Map |
29 | 37 | ||
38 | import Data.Set (Set) | ||
39 | import qualified Data.Set as Set | ||
40 | |||
30 | import Data.Aeson | 41 | import Data.Aeson |
42 | import Data.Traversable | ||
43 | import Data.Maybe | ||
44 | import Data.Bool | ||
45 | import Data.String (IsString(..)) | ||
46 | import Data.Unique | ||
47 | import Data.List (sortOn) | ||
48 | import Data.Ord | ||
31 | 49 | ||
32 | 50 | ||
33 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| | 51 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| |
@@ -36,46 +54,402 @@ Item | |||
36 | bought Day Maybe | 54 | bought Day Maybe |
37 | expires Day Maybe | 55 | expires Day Maybe |
38 | opened Day Maybe | 56 | opened Day Maybe |
39 | deriving Show | 57 | deriving Show Eq |
40 | |] | 58 | |] |
41 | 59 | ||
60 | instance Ord Item where | ||
61 | x `compare` y = mconcat | ||
62 | [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y) | ||
63 | , itemOpened x `compare` itemOpened y | ||
64 | , itemExpires x `compare` itemExpires x | ||
65 | , itemKind x `compare` itemKind x | ||
66 | , itemBought x `compare` itemBought x | ||
67 | ] | ||
68 | |||
42 | instance ToJSON Item where | 69 | instance ToJSON Item where |
43 | toJSON Item{..} = object | 70 | toJSON Item{..} = object $ |
44 | [ "kind" .= itemKind | 71 | [ "kind" .= itemKind |
45 | , "bought" .= itemBought | 72 | ] ++ maybe [] (\x -> ["bought" .= x]) itemBought |
46 | , "expires" .= itemExpires | 73 | ++ maybe [] (\x -> ["expires" .= x]) itemExpires |
47 | , "opened" .= itemOpened | 74 | ++ maybe [] (\x -> ["opened" .= x]) itemOpened |
48 | ] | 75 | |
76 | instance FromJSON Item where | ||
77 | parseJSON = withObject "Item" $ \obj -> do | ||
78 | itemKind <- obj .: "kind" | ||
79 | itemBought <- obj .:? "bought" | ||
80 | itemExpires <- obj .:? "expires" | ||
81 | itemOpened <- obj .:? "opened" | ||
82 | return Item{..} | ||
49 | 83 | ||
50 | instance ToJSON (Entity Item) where | 84 | instance ToJSON (Entity Item) where |
51 | toJSON = entityIdToJSON | 85 | toJSON = entityIdToJSON |
52 | 86 | ||
87 | instance FromJSON (Entity Item) where | ||
88 | parseJSON = entityIdFromJSON | ||
89 | |||
90 | data ItemDiff = DiffKind Text | ||
91 | | DiffBought (Maybe Day) | ||
92 | | DiffExpires (Maybe Day) | ||
93 | | DiffOpened (Maybe Day) | ||
94 | |||
95 | newtype ItemDiffs = ItemDiffs [ItemDiff] | ||
53 | 96 | ||
97 | instance FromJSON ItemDiffs where | ||
98 | parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do | ||
99 | tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind") | ||
100 | tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought") | ||
101 | tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires") | ||
102 | tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened") | ||
103 | |||
104 | toUpdate :: ItemDiffs -> [Update Item] | ||
105 | toUpdate (ItemDiffs ds) = do | ||
106 | x <- ds | ||
107 | return $ case x of | ||
108 | DiffKind t -> ItemKind =. t | ||
109 | DiffBought d -> ItemBought =. d | ||
110 | DiffExpires d -> ItemExpires =. d | ||
111 | DiffOpened d -> ItemOpened =. d | ||
112 | |||
113 | |||
54 | data BarInventory = BarInventory | 114 | data BarInventory = BarInventory |
55 | { sqlPool :: ConnectionPool | 115 | { sqlPool :: ConnectionPool |
56 | } | 116 | } |
57 | 117 | ||
58 | mkYesod "BarInventory" [parseRoutes| | 118 | mkYesod "BarInventory" [parseRoutes| |
59 | / InventoryR GET | 119 | / InventoryR GET PUT POST |
120 | /#ItemId ItemR GET PUT PATCH DELETE | ||
121 | /#ItemId/open OpenItemR POST | ||
122 | /#ItemId/update UpdateItemR POST GET | ||
123 | /#ItemId/delete DeleteItemR POST | ||
60 | |] | 124 | |] |
61 | 125 | ||
62 | instance Yesod BarInventory | 126 | instance Yesod BarInventory |
63 | 127 | ||
128 | instance RenderMessage BarInventory FormMessage where | ||
129 | renderMessage _ _ = defaultFormMessage | ||
130 | |||
64 | instance YesodPersist BarInventory where | 131 | instance YesodPersist BarInventory where |
65 | type YesodPersistBackend BarInventory = SqlBackend | 132 | type YesodPersistBackend BarInventory = SqlBackend |
66 | 133 | ||
67 | runDB action = runSqlPool action . sqlPool =<< getYesod | 134 | runDB action = runSqlPool action . sqlPool =<< getYesod |
68 | 135 | ||
69 | 136 | ||
70 | main = runStderrLoggingT . withPostgresqlPool "" 5 . runReaderT $ do | 137 | data ViewState = ViewState |
138 | { errs :: [Text] | ||
139 | , insertForm :: Maybe Widget | ||
140 | , insertEncoding :: Maybe Enctype | ||
141 | , stock :: [Entity Item] | ||
142 | , updateItem :: Maybe ItemId | ||
143 | , updateForm :: Maybe Widget | ||
144 | , updateEncoding :: Maybe Enctype | ||
145 | } | ||
146 | |||
147 | |||
148 | |||
149 | main = runStderrLoggingT . withPostgresqlPool "user=bar dbname=bar" 5 . runReaderT $ do | ||
71 | sqlPool <- ask | 150 | sqlPool <- ask |
72 | mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) sqlPool | 151 | mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) sqlPool |
73 | liftIO . warpEnv $ BarInventory{..} | 152 | liftIO . warpEnv $ BarInventory{..} |
74 | 153 | ||
75 | 154 | ||
76 | getInventoryR :: Handler TypedContent | 155 | itemFragment itemId = "item" <> show (fromSqlKey itemId) |
156 | |||
157 | itemForm :: Maybe Item -> Html -> MForm Handler (FormResult Item, Widget) | ||
158 | itemForm proto identView = do | ||
159 | today <- utctDay <$> liftIO getCurrentTime | ||
160 | |||
161 | (kindRes, kindView) <- mreq textField "" $ itemKind <$> proto | ||
162 | (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown" | ||
163 | (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never" | ||
164 | (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never" | ||
165 | |||
166 | let itemRes = do | ||
167 | itemKind <- kindRes | ||
168 | itemBought <- boughtRes | ||
169 | itemExpires <- expiresRes | ||
170 | itemOpened <- openedRes | ||
171 | return Item{..} | ||
172 | |||
173 | return . (itemRes, ) $ do | ||
174 | toWidget | ||
175 | [cassius| | ||
176 | label.checkbox | ||
177 | input | ||
178 | vertical-align: middle | ||
179 | span | ||
180 | vertical-align: middle | ||
181 | |] | ||
182 | -- addScriptRemote "https://cdn.jsdelivr.net/webshim/1.16.0/extras/modernizr-custom.js" | ||
183 | addScriptRemote "https://cdn.jsdelivr.net/webshim/1.16.0/polyfiller.js" | ||
184 | addScriptRemote "https://cdn.jsdelivr.net/jquery/3.1.1/jquery.js" | ||
185 | toWidget | ||
186 | [julius| | ||
187 | webshims.setOptions("forms-ext", { | ||
188 | "widgets": { | ||
189 | "classes": "hide-dropdownbtn" | ||
190 | } | ||
191 | }); | ||
192 | webshims.activeLang("en-GB"); | ||
193 | webshims.polyfill("forms forms-ext"); | ||
194 | |] | ||
195 | [whamlet| | ||
196 | #{identView} | ||
197 | <div .td>^{fvInput kindView} | ||
198 | <div .td>^{boughtWidget} | ||
199 | <div .td>^{expiresWidget} | ||
200 | <div .td>^{openedWidget} | ||
201 | |] | ||
202 | where | ||
203 | dayForm :: Maybe (Maybe Day) -> String -> MForm Handler (FormResult (Maybe Day), Widget) | ||
204 | dayForm proto label = do | ||
205 | today <- utctDay <$> liftIO getCurrentTime | ||
206 | |||
207 | checkboxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique | ||
208 | |||
209 | (fmap (fromMaybe False) -> isNothingRes, isNothingView) <- | ||
210 | mopt checkBoxField ("" { fsId = Just $ Text.pack checkboxId }) . Just . Just . fromMaybe True $ fmap isNothing proto | ||
211 | (dayRes, dayView) <- | ||
212 | mreq dayField "" . Just . fromMaybe today $ join proto | ||
213 | |||
214 | let res = (bool Just (const Nothing) <$> isNothingRes) <*> dayRes | ||
215 | return . (res, ) $ do | ||
216 | [whamlet| | ||
217 | $newline never | ||
218 | <div .table> | ||
219 | <div .tr> | ||
220 | <label for=#{checkboxId} .checkbox .td> | ||
221 | ^{fvInput isNothingView} | ||
222 | <span> | ||
223 | #{label} | ||
224 | <div .tr> | ||
225 | <div .td .dayInput>^{fvInput dayView} | ||
226 | |] | ||
227 | |||
228 | |||
229 | |||
230 | getInventoryR, postInventoryR :: Handler TypedContent | ||
231 | postInventoryR = getInventoryR | ||
77 | getInventoryR = do | 232 | getInventoryR = do |
78 | stock <- runDB $ selectList [] [] | 233 | ((insertResult, (Just -> insertForm)), (Just -> insertEncoding)) <- runFormPost $ itemForm Nothing |
234 | |||
235 | errs <- case insertResult of | ||
236 | FormSuccess newItem -> [] <$ runDB (insert newItem) | ||
237 | FormFailure errors -> return errors | ||
238 | _ -> return [] | ||
239 | |||
240 | (sortOn entityVal -> stock) <- runDB $ selectList [] [] | ||
241 | |||
242 | selectRep $ do | ||
243 | provideJson (stock :: [Entity Item]) | ||
244 | provideRep $ mainView ViewState | ||
245 | { updateItem = Nothing | ||
246 | , updateForm = Nothing | ||
247 | , updateEncoding = Nothing | ||
248 | , .. | ||
249 | } | ||
250 | |||
251 | postUpdateItemR, getUpdateItemR :: ItemId -> Handler TypedContent | ||
252 | postUpdateItemR = getUpdateItemR | ||
253 | getUpdateItemR updateItem = do | ||
254 | Just entity <- fmap (Entity updateItem) <$> runDB (get updateItem) | ||
79 | 255 | ||
256 | ((updateResult, (Just -> updateForm)), (Just -> updateEncoding)) <- runFormPost . itemForm . Just $ entityVal entity | ||
257 | |||
258 | errs <- case updateResult of | ||
259 | FormSuccess Item{..} -> [] <$ runDB (update updateItem [ ItemKind =. itemKind | ||
260 | , ItemBought =. itemBought | ||
261 | , ItemExpires =. itemExpires | ||
262 | , ItemOpened =. itemOpened | ||
263 | ]) | ||
264 | FormFailure errors -> return errors | ||
265 | _ -> return [] | ||
266 | |||
267 | selectRep $ do | ||
268 | provideRep $ case updateResult of | ||
269 | FormSuccess _ -> redirect $ InventoryR :#: itemFragment updateItem :: Handler Html | ||
270 | _ -> do | ||
271 | (sortOn entityVal -> stock) <- runDB $ selectList [] [] | ||
272 | mainView ViewState | ||
273 | { insertForm = Nothing | ||
274 | , insertEncoding = Nothing | ||
275 | , updateItem = Just updateItem | ||
276 | , .. | ||
277 | } | ||
278 | provideJson () | ||
279 | |||
280 | mainView :: ViewState -> Handler Html | ||
281 | mainView ViewState{..} = defaultLayout $ do | ||
282 | let | ||
283 | dayFormat = formatTime defaultTimeLocale "%e. %b %y" | ||
284 | |||
285 | setTitle "Bar Inventory" | ||
286 | toWidget | ||
287 | [cassius| | ||
288 | .table | ||
289 | display: table | ||
290 | .table div | ||
291 | vertical-align: middle | ||
292 | .td | ||
293 | display: table-cell | ||
294 | text-align: center | ||
295 | padding: 0.25em | ||
296 | .tr | ||
297 | display: table-row | ||
298 | .tc | ||
299 | display: table-caption | ||
300 | padding: 0.25em | ||
301 | .th | ||
302 | display: table-cell | ||
303 | font-variant: small-caps | ||
304 | font-weight: bold | ||
305 | text-align: center | ||
306 | padding: 0.25em | ||
307 | .kind | ||
308 | display: table-cell | ||
309 | text-align: left | ||
310 | padding: 0.25em | ||
311 | .table .table .td, .table .table .tc, .table .table .th, .table .table .kind | ||
312 | padding: 0 | ||
313 | .error | ||
314 | background-color: #fdd | ||
315 | text-align: center | ||
316 | color: #c00 | ||
317 | list-style-type: none | ||
318 | button | ||
319 | width: 6em | ||
320 | display:inline-text | ||
321 | .day hr | ||
322 | width: 2em | ||
323 | border: 1px solid #ddd | ||
324 | border-style: solid none solid none | ||
325 | .sepBelow > div, .sepAbove > div | ||
326 | border: 2px none #ddd | ||
327 | .sepBelow > div | ||
328 | border-bottom-style: solid | ||
329 | .sepAbove > div | ||
330 | border-top-style: solid | ||
331 | .color:nth-child(even) | ||
332 | background-color: #f0f0f0 | ||
333 | .color:nth-child(odd) | ||
334 | background-color: #fff | ||
335 | body > div | ||
336 | margin: 0 auto | ||
337 | .table > h1 | ||
338 | display: table-caption | ||
339 | h1 | ||
340 | font-size: 1.5em | ||
341 | font-weight: bold | ||
342 | font-variant: small-caps | ||
343 | text-align: center | ||
344 | margin:0 0 .5em 0 | ||
345 | |] | ||
346 | toWidget | ||
347 | [whamlet| | ||
348 | <div .table> | ||
349 | <h1> | ||
350 | Inventory | ||
351 | $if not $ null errs | ||
352 | <ul .tc .error .sepBelow> | ||
353 | $forall e <- errs | ||
354 | <li>#{e} | ||
355 | <div .tr .sepBelow> | ||
356 | <div .th>Description | ||
357 | <div .th>Bought | ||
358 | <div .th>Expires | ||
359 | <div .th>Opened | ||
360 | <div .th>Actions | ||
361 | $maybe insertEncoding <- insertEncoding | ||
362 | $maybe insertForm <- insertForm | ||
363 | <form .tr .sepBelow action=@{InventoryR} method=post enctype=#{insertEncoding}> | ||
364 | ^{insertForm} | ||
365 | <div .td> | ||
366 | <button type=submit> | ||
367 | Insert | ||
368 | $forall e@(Entity itemId Item{..}) <- stock | ||
369 | $with idN <- fromSqlKey itemId | ||
370 | $if and [ Just itemId == updateItem, isJust updateEncoding, isJust updateForm ] | ||
371 | $maybe updateEncoding <- updateEncoding | ||
372 | $maybe updateForm <- updateForm | ||
373 | <form .tr .color action=@{UpdateItemR itemId}##{itemFragment itemId} method=post enctype=#{updateEncoding} ##{itemFragment itemId}> | ||
374 | ^{updateForm} | ||
375 | <div .td> | ||
376 | <button type=submit> | ||
377 | Save Changes | ||
378 | $else | ||
379 | <div .tr .color ##{itemFragment itemId}> | ||
380 | <div .kind>#{itemKind} | ||
381 | <div .td .day> | ||
382 | $maybe bought <- itemBought | ||
383 | #{dayFormat bought} | ||
384 | $nothing | ||
385 | <hr> | ||
386 | <div .td .day> | ||
387 | $maybe expires <- itemExpires | ||
388 | #{dayFormat expires} | ||
389 | $nothing | ||
390 | <hr> | ||
391 | <div .td .day> | ||
392 | $maybe opened <- itemOpened | ||
393 | #{dayFormat opened} | ||
394 | $nothing | ||
395 | <form method=post action=@{OpenItemR itemId}> | ||
396 | <button type=submit> | ||
397 | Open | ||
398 | <div .td> | ||
399 | <form method=get action=@{UpdateItemR itemId}##{itemFragment itemId}> | ||
400 | <button type=submit> | ||
401 | Alter | ||
402 | <form method=post action=@{DeleteItemR itemId}> | ||
403 | <button type=submit> | ||
404 | Delete | ||
405 | |] | ||
406 | |||
407 | putInventoryR :: Handler Value | ||
408 | putInventoryR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Item) | ||
409 | |||
410 | getItemR :: ItemId -> Handler TypedContent | ||
411 | getItemR itemId = do | ||
412 | let getEntity id = fmap (Entity id) <$> get id | ||
413 | |||
414 | eLookup <- runDB $ getEntity itemId | ||
415 | |||
416 | case eLookup of | ||
417 | Nothing -> notFound | ||
418 | Just entity -> do | ||
419 | |||
420 | selectRep $ do | ||
421 | provideJson entity | ||
422 | |||
423 | patchItemR :: ItemId -> Handler Value | ||
424 | patchItemR itemId = do | ||
425 | diffs <- (requireCheckJsonBody :: Handler ItemDiffs) | ||
426 | returnJson . Entity itemId =<< runDB (updateGet itemId $ toUpdate diffs) | ||
427 | |||
428 | putItemR :: ItemId -> Handler Value | ||
429 | putItemR itemId = do | ||
430 | Item{..} <- requireCheckJsonBody | ||
431 | returnJson . Entity itemId =<< runDB | ||
432 | (updateGet itemId [ ItemKind =. itemKind | ||
433 | , ItemBought =. itemBought | ||
434 | , ItemExpires =. itemExpires | ||
435 | , ItemOpened =. itemOpened | ||
436 | ]) | ||
437 | |||
438 | deleteItemR :: ItemId -> Handler () | ||
439 | deleteItemR = runDB . delete | ||
440 | |||
441 | postDeleteItemR :: ItemId -> Handler TypedContent | ||
442 | postDeleteItemR itemId = do | ||
443 | runDB $ delete itemId | ||
444 | selectRep $ do | ||
445 | provideJson () | ||
446 | provideRep (redirect $ InventoryR :: Handler Html) | ||
447 | |||
448 | postOpenItemR :: ItemId -> Handler TypedContent | ||
449 | postOpenItemR itemId = do | ||
450 | today <- utctDay <$> liftIO getCurrentTime | ||
451 | result <- fmap (Entity itemId) . runDB $ updateGet itemId [ ItemOpened =. Just today | ||
452 | ] | ||
80 | selectRep $ do | 453 | selectRep $ do |
81 | provideRep . return . toJSON $ (stock :: [Entity Item]) | 454 | provideJson result |
455 | provideRep (redirect $ InventoryR :#: itemFragment itemId :: Handler Html) | ||