Bar.hs

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 @@
+#! /usr/bin/env nix-shell
+#! nix-shell -i runghc -p "haskellPackages.ghcWithPackages (p: with p; [ yesod persistent-postgresql ])"
+
+
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleInstances          #-}
+  
+
+import Yesod
+import Database.Persist.Postgresql
+import Control.Monad.Logger (runStderrLoggingT)
+import Control.Monad.Reader
+
+import Data.Time.Calendar
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+import Data.Map.Lazy (Map)
+import qualified Data.Map.Lazy as Map
+
+import Data.Aeson
+
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+Item
+    kind Text
+    bought Day Maybe
+    expires Day Maybe
+    opened Day Maybe
+    deriving Show
+|]
+
+instance ToJSON Item where
+  toJSON Item{..} = object
+    [ "kind" .= itemKind
+    , "bought" .= itemBought
+    , "expires" .= itemExpires
+    , "opened" .= itemOpened
+    ]
+  
+instance ToJSON (Entity Item) where
+  toJSON = entityIdToJSON
+
+
+data BarInventory = BarInventory
+  { sqlPool :: ConnectionPool
+  }
+
+mkYesod "BarInventory" [parseRoutes|
+/ InventoryR GET
+|]
+
+instance Yesod BarInventory
+
+instance YesodPersist BarInventory where
+  type YesodPersistBackend BarInventory = SqlBackend
+
+  runDB action = runSqlPool action . sqlPool =<< getYesod
+
+
+main = runStderrLoggingT . withPostgresqlPool "" 5 . runReaderT $ do
+  sqlPool <- ask
+  liftIO . warpEnv $ BarInventory{..}
+
+
+getInventoryR :: Handler TypedContent
+getInventoryR = do
+  stock <- runDB $ selectList [] []
+  
+  selectRep $ do
+    provideRep . return . toJSON $ (stock :: [Entity Item])