From cf8aef18aad8e92f699165350ec4e18a0f2ee3f5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 6 Mar 2017 21:13:03 +0100 Subject: Migrate thermoprint-server to postgresql --- bragi/thermoprint-server/thermoprint-server.hs | 30 ++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 bragi/thermoprint-server/thermoprint-server.hs (limited to 'bragi') diff --git a/bragi/thermoprint-server/thermoprint-server.hs b/bragi/thermoprint-server/thermoprint-server.hs new file mode 100644 index 00000000..4f909f80 --- /dev/null +++ b/bragi/thermoprint-server/thermoprint-server.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImpredicativeTypes #-} + +module Main (main) where + +import Thermoprint.Server + +import Thermoprint.Server.Printer.Generic + +import Control.Monad.Trans.Resource +import Control.Monad.Logger +import Control.Monad.Reader + +import Database.Persist.Postgresql + +main :: IO () +main = thermoprintServer True (Nat runDb) $ (\c -> c { queueManagers = queueManagers }) <$> def `withPrinters` printers + where + runDb :: ReaderT ConnectionPool (LoggingT IO) a -> IO a + runDb = runStderrLoggingT . withPostgresqlPool "" 5 . runReaderT + + printers = [ (pure $ genericPrint "/dev/usb/lp0", def) + ] + + queueManagers _ = QMConfig + { manager = union [ limitHistorySize 100 + , limitHistoryAge 3600 + ] + , collapse = standardCollapse + } -- cgit v1.2.3 From b519427c4e02671dffa24aa6e6ddf536480fb9d4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 9 Mar 2017 21:30:10 +0100 Subject: Add types to thermoprint-server --- bragi/thermoprint-server/thermoprint-server.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'bragi') diff --git a/bragi/thermoprint-server/thermoprint-server.hs b/bragi/thermoprint-server/thermoprint-server.hs index 4f909f80..6142e7d9 100644 --- a/bragi/thermoprint-server/thermoprint-server.hs +++ b/bragi/thermoprint-server/thermoprint-server.hs @@ -13,12 +13,15 @@ import Control.Monad.Reader import Database.Persist.Postgresql +type ServerM = ReaderT ConnectionPool (LoggingT IO) + main :: IO () main = thermoprintServer True (Nat runDb) $ (\c -> c { queueManagers = queueManagers }) <$> def `withPrinters` printers where - runDb :: ReaderT ConnectionPool (LoggingT IO) a -> IO a + runDb :: ServerM a -> IO a runDb = runStderrLoggingT . withPostgresqlPool "" 5 . runReaderT + printers :: [(ResourceT ServerM PrinterMethod, QMConfig (ResourceT ServerM))] printers = [ (pure $ genericPrint "/dev/usb/lp0", def) ] -- cgit v1.2.3 From 03025c105e5fb3055e57e2df9d2af258d579ff7f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 9 Mar 2017 21:58:34 +0100 Subject: Configure warp --- bragi/thermoprint-server/thermoprint-server.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) (limited to 'bragi') diff --git a/bragi/thermoprint-server/thermoprint-server.hs b/bragi/thermoprint-server/thermoprint-server.hs index 6142e7d9..97b37374 100644 --- a/bragi/thermoprint-server/thermoprint-server.hs +++ b/bragi/thermoprint-server/thermoprint-server.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE RecordWildCards #-} module Main (main) where @@ -11,19 +12,22 @@ import Control.Monad.Trans.Resource import Control.Monad.Logger import Control.Monad.Reader +import Data.Function ((&)) + import Database.Persist.Postgresql +import qualified Network.Wai.Handler.Warp as Warp + type ServerM = ReaderT ConnectionPool (LoggingT IO) main :: IO () -main = thermoprintServer True (Nat runDb) $ (\c -> c { queueManagers = queueManagers }) <$> def `withPrinters` printers +main = thermoprintServer True (Nat runDb) $ configure (\c -> c{..}) <$> def `withPrinters` printers' where runDb :: ServerM a -> IO a runDb = runStderrLoggingT . withPostgresqlPool "" 5 . runReaderT - printers :: [(ResourceT ServerM PrinterMethod, QMConfig (ResourceT ServerM))] - printers = [ (pure $ genericPrint "/dev/usb/lp0", def) - ] + printers' = [ (pure $ genericPrint "/dev/usb/lp0", def :: QMConfig (ResourceT ServerM)) + ] queueManagers _ = QMConfig { manager = union [ limitHistorySize 100 @@ -31,3 +35,7 @@ main = thermoprintServer True (Nat runDb) $ (\c -> c { queueManagers = queueMana ] , collapse = standardCollapse } + + warpSettings = Warp.defaultSettings + & Warp.setHost "localhost" + & Warp.setPort 8080 -- cgit v1.2.3 From cf6ba7cbff444db49797076b70a639961f29e8ef Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 9 Mar 2017 22:02:46 +0100 Subject: Syntax --- bragi/thermoprint-server/thermoprint-server.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'bragi') diff --git a/bragi/thermoprint-server/thermoprint-server.hs b/bragi/thermoprint-server/thermoprint-server.hs index 97b37374..7e571021 100644 --- a/bragi/thermoprint-server/thermoprint-server.hs +++ b/bragi/thermoprint-server/thermoprint-server.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE RecordWildCards #-} module Main (main) where @@ -21,7 +20,7 @@ import qualified Network.Wai.Handler.Warp as Warp type ServerM = ReaderT ConnectionPool (LoggingT IO) main :: IO () -main = thermoprintServer True (Nat runDb) $ configure (\c -> c{..}) <$> def `withPrinters` printers' +main = thermoprintServer True (Nat runDb) $ configure <$> def `withPrinters` printers' where runDb :: ServerM a -> IO a runDb = runStderrLoggingT . withPostgresqlPool "" 5 . runReaderT @@ -29,6 +28,11 @@ main = thermoprintServer True (Nat runDb) $ configure (\c -> c{..}) <$> def `wit printers' = [ (pure $ genericPrint "/dev/usb/lp0", def :: QMConfig (ResourceT ServerM)) ] + configure c = c + { queueManagers = queueManagers + , warpSettings = warpSettings + } + queueManagers _ = QMConfig { manager = union [ limitHistorySize 100 , limitHistoryAge 3600 -- cgit v1.2.3 From 5f7dfe0b58e961d4f798691e6067d61e44460470 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 9 Mar 2017 22:08:24 +0100 Subject: Poke thermoprint config --- bragi/thermoprint-server/thermoprint-server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'bragi') diff --git a/bragi/thermoprint-server/thermoprint-server.hs b/bragi/thermoprint-server/thermoprint-server.hs index 7e571021..4635dd0a 100644 --- a/bragi/thermoprint-server/thermoprint-server.hs +++ b/bragi/thermoprint-server/thermoprint-server.hs @@ -41,5 +41,5 @@ main = thermoprintServer True (Nat runDb) $ configure <$> def `withPrinters` pri } warpSettings = Warp.defaultSettings - & Warp.setHost "localhost" + & Warp.setHost "::1" & Warp.setPort 8080 -- cgit v1.2.3 From 5052da408a92789628bef30c83ad6da65d7d6fc9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 10 Mar 2017 00:43:03 +0100 Subject: Bar.hs --- bragi/bar.hs | 80 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 80 insertions(+) create mode 100755 bragi/bar.hs (limited to 'bragi') 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]) -- cgit v1.2.3 From 0eeb4d561ab478747d721db4a0f015b7b976fb32 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 10 Mar 2017 01:13:25 +0100 Subject: Run migration --- bragi/bar.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'bragi') diff --git a/bragi/bar.hs b/bragi/bar.hs index 43e1306b..067e5af4 100755 --- a/bragi/bar.hs +++ b/bragi/bar.hs @@ -69,6 +69,7 @@ instance YesodPersist BarInventory where main = runStderrLoggingT . withPostgresqlPool "" 5 . runReaderT $ do sqlPool <- ask + mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) sqlPool liftIO . warpEnv $ BarInventory{..} -- cgit v1.2.3 From a91deb0648eaf9e8526236c6e4cf29159567ceeb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 11 Mar 2017 21:37:45 +0100 Subject: Feature complete bar --- bragi/bar.hs | 396 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 385 insertions(+), 11 deletions(-) (limited to 'bragi') 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 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ApplicativeDo #-} import Yesod import Database.Persist.Postgresql + import Control.Monad.Logger (runStderrLoggingT) import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Trans.Maybe +import Data.Time.Clock import Data.Time.Calendar +import Data.Time.Format import Data.Text (Text) import qualified Data.Text as Text @@ -27,7 +35,17 @@ import qualified Data.Text as Text import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map +import Data.Set (Set) +import qualified Data.Set as Set + import Data.Aeson +import Data.Traversable +import Data.Maybe +import Data.Bool +import Data.String (IsString(..)) +import Data.Unique +import Data.List (sortOn) +import Data.Ord share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| @@ -36,46 +54,402 @@ Item bought Day Maybe expires Day Maybe opened Day Maybe - deriving Show + deriving Show Eq |] +instance Ord Item where + x `compare` y = mconcat + [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y) + , itemOpened x `compare` itemOpened y + , itemExpires x `compare` itemExpires x + , itemKind x `compare` itemKind x + , itemBought x `compare` itemBought x + ] + instance ToJSON Item where - toJSON Item{..} = object + toJSON Item{..} = object $ [ "kind" .= itemKind - , "bought" .= itemBought - , "expires" .= itemExpires - , "opened" .= itemOpened - ] + ] ++ maybe [] (\x -> ["bought" .= x]) itemBought + ++ maybe [] (\x -> ["expires" .= x]) itemExpires + ++ maybe [] (\x -> ["opened" .= x]) itemOpened + +instance FromJSON Item where + parseJSON = withObject "Item" $ \obj -> do + itemKind <- obj .: "kind" + itemBought <- obj .:? "bought" + itemExpires <- obj .:? "expires" + itemOpened <- obj .:? "opened" + return Item{..} instance ToJSON (Entity Item) where toJSON = entityIdToJSON +instance FromJSON (Entity Item) where + parseJSON = entityIdFromJSON + +data ItemDiff = DiffKind Text + | DiffBought (Maybe Day) + | DiffExpires (Maybe Day) + | DiffOpened (Maybe Day) + +newtype ItemDiffs = ItemDiffs [ItemDiff] +instance FromJSON ItemDiffs where + parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do + tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind") + tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought") + tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires") + tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened") + +toUpdate :: ItemDiffs -> [Update Item] +toUpdate (ItemDiffs ds) = do + x <- ds + return $ case x of + DiffKind t -> ItemKind =. t + DiffBought d -> ItemBought =. d + DiffExpires d -> ItemExpires =. d + DiffOpened d -> ItemOpened =. d + + data BarInventory = BarInventory { sqlPool :: ConnectionPool } mkYesod "BarInventory" [parseRoutes| -/ InventoryR GET +/ InventoryR GET PUT POST +/#ItemId ItemR GET PUT PATCH DELETE +/#ItemId/open OpenItemR POST +/#ItemId/update UpdateItemR POST GET +/#ItemId/delete DeleteItemR POST |] instance Yesod BarInventory +instance RenderMessage BarInventory FormMessage where + renderMessage _ _ = defaultFormMessage + instance YesodPersist BarInventory where type YesodPersistBackend BarInventory = SqlBackend runDB action = runSqlPool action . sqlPool =<< getYesod -main = runStderrLoggingT . withPostgresqlPool "" 5 . runReaderT $ do +data ViewState = ViewState + { errs :: [Text] + , insertForm :: Maybe Widget + , insertEncoding :: Maybe Enctype + , stock :: [Entity Item] + , updateItem :: Maybe ItemId + , updateForm :: Maybe Widget + , updateEncoding :: Maybe Enctype + } + + + +main = runStderrLoggingT . withPostgresqlPool "user=bar dbname=bar" 5 . runReaderT $ do sqlPool <- ask mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) sqlPool liftIO . warpEnv $ BarInventory{..} -getInventoryR :: Handler TypedContent +itemFragment itemId = "item" <> show (fromSqlKey itemId) + +itemForm :: Maybe Item -> Html -> MForm Handler (FormResult Item, Widget) +itemForm proto identView = do + today <- utctDay <$> liftIO getCurrentTime + + (kindRes, kindView) <- mreq textField "" $ itemKind <$> proto + (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown" + (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never" + (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never" + + let itemRes = do + itemKind <- kindRes + itemBought <- boughtRes + itemExpires <- expiresRes + itemOpened <- openedRes + return Item{..} + + return . (itemRes, ) $ do + toWidget + [cassius| + label.checkbox + input + vertical-align: middle + span + vertical-align: middle + |] + -- addScriptRemote "https://cdn.jsdelivr.net/webshim/1.16.0/extras/modernizr-custom.js" + addScriptRemote "https://cdn.jsdelivr.net/webshim/1.16.0/polyfiller.js" + addScriptRemote "https://cdn.jsdelivr.net/jquery/3.1.1/jquery.js" + toWidget + [julius| + webshims.setOptions("forms-ext", { + "widgets": { + "classes": "hide-dropdownbtn" + } + }); + webshims.activeLang("en-GB"); + webshims.polyfill("forms forms-ext"); + |] + [whamlet| + #{identView} +
^{fvInput kindView} +
^{boughtWidget} +
^{expiresWidget} +
^{openedWidget} + |] + where + dayForm :: Maybe (Maybe Day) -> String -> MForm Handler (FormResult (Maybe Day), Widget) + dayForm proto label = do + today <- utctDay <$> liftIO getCurrentTime + + checkboxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique + + (fmap (fromMaybe False) -> isNothingRes, isNothingView) <- + mopt checkBoxField ("" { fsId = Just $ Text.pack checkboxId }) . Just . Just . fromMaybe True $ fmap isNothing proto + (dayRes, dayView) <- + mreq dayField "" . Just . fromMaybe today $ join proto + + let res = (bool Just (const Nothing) <$> isNothingRes) <*> dayRes + return . (res, ) $ do + [whamlet| + $newline never +
+
+