summaryrefslogtreecommitdiff
path: root/bragi/bar.hs
diff options
context:
space:
mode:
Diffstat (limited to 'bragi/bar.hs')
-rwxr-xr-xbragi/bar.hs80
1 files changed, 80 insertions, 0 deletions
diff --git a/bragi/bar.hs b/bragi/bar.hs
new file mode 100755
index 00000000..43e1306b
--- /dev/null
+++ b/bragi/bar.hs
@@ -0,0 +1,80 @@
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
16
17import Yesod
18import Database.Persist.Postgresql
19import Control.Monad.Logger (runStderrLoggingT)
20import Control.Monad.Reader
21
22import Data.Time.Calendar
23
24import Data.Text (Text)
25import qualified Data.Text as Text
26
27import Data.Map.Lazy (Map)
28import qualified Data.Map.Lazy as Map
29
30import Data.Aeson
31
32
33share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
34Item
35 kind Text
36 bought Day Maybe
37 expires Day Maybe
38 opened Day Maybe
39 deriving Show
40|]
41
42instance ToJSON Item where
43 toJSON Item{..} = object
44 [ "kind" .= itemKind
45 , "bought" .= itemBought
46 , "expires" .= itemExpires
47 , "opened" .= itemOpened
48 ]
49
50instance ToJSON (Entity Item) where
51 toJSON = entityIdToJSON
52
53
54data BarInventory = BarInventory
55 { sqlPool :: ConnectionPool
56 }
57
58mkYesod "BarInventory" [parseRoutes|
59/ InventoryR GET
60|]
61
62instance Yesod BarInventory
63
64instance YesodPersist BarInventory where
65 type YesodPersistBackend BarInventory = SqlBackend
66
67 runDB action = runSqlPool action . sqlPool =<< getYesod
68
69
70main = runStderrLoggingT . withPostgresqlPool "" 5 . runReaderT $ do
71 sqlPool <- ask
72 liftIO . warpEnv $ BarInventory{..}
73
74
75getInventoryR :: Handler TypedContent
76getInventoryR = do
77 stock <- runDB $ selectList [] []
78
79 selectRep $ do
80 provideRep . return . toJSON $ (stock :: [Entity Item])