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