From 47f54fc6d1f081c9fe7ac3d0bee705b3a78609d5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 14 Mar 2017 01:23:09 +0100 Subject: Switch to bar in repo --- .gitignore | 4 +- bragi.nix | 4 +- bragi/bar.hs | 462 -------------------------------------------- bragi/bar/default.nix | 30 +++ bragi/bar/generated.nix | 34 ++++ bragi/bar/generated.nix.gup | 5 + 6 files changed, 75 insertions(+), 464 deletions(-) delete mode 100755 bragi/bar.hs create mode 100644 bragi/bar/default.nix create mode 100644 bragi/bar/generated.nix create mode 100644 bragi/bar/generated.nix.gup diff --git a/.gitignore b/.gitignore index 3b10a887..eb514beb 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ configuration.nix config.nix -**/\#*\# \ No newline at end of file +**/\#*\# +**/.gup/ +**/result diff --git a/bragi.nix b/bragi.nix index 86c24228..ff58967f 100644 --- a/bragi.nix +++ b/bragi.nix @@ -315,7 +315,9 @@ in rec { wantedBy = [ "default.target" ]; serviceConfig = { Type = "simple"; - ExecStart = "${ghc}/bin/runghc ${./bragi/bar.hs}"; + ExecStart = '' + ${pkgs.callPackage ./bragi/bar {}}/bin/bar + ''; User = users.extraUsers."bar".name; Group = users.extraUsers."bar".group; WorkingDirectory = "~"; 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 @@ -#! /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 #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ApplicativeDo #-} - - -import Yesod -import Database.Persist.Postgresql -import Network.Wai (requestHeaders) - -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 - -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Encoding.Error as TEE - -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| -Item - kind Text - bought Day Maybe - expires Day Maybe - opened Day Maybe - deriving Show Eq -|] - -instance Ord Item where - x `compare` y = mconcat - [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y) - , itemOpened x `compare` itemOpened y - , (isNothing $ itemExpires x) `compare` (isNothing $ itemExpires y) - , itemExpires x `compare` itemExpires x - , itemKind x `compare` itemKind x - , itemBought x `compare` itemBought x - ] - -instance ToJSON Item where - toJSON Item{..} = object $ - [ "kind" .= itemKind - ] ++ 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 PUT POST -/#ItemId ItemR GET PUT PATCH DELETE -/#ItemId/open OpenItemR POST -/#ItemId/update UpdateItemR POST GET -/#ItemId/delete DeleteItemR POST -|] - -instance Yesod BarInventory where - approot = ApprootRequest $ \_ req -> maybe "" (TE.decodeUtf8With TEE.lenientDecode) $ Map.lookup "AppRoot" (Map.fromList $ requestHeaders req) - -instance RenderMessage BarInventory FormMessage where - renderMessage _ _ = defaultFormMessage - -instance YesodPersist BarInventory where - type YesodPersistBackend BarInventory = SqlBackend - - runDB action = runSqlPool action . sqlPool =<< getYesod - - -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{..} - - -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 -
-
-