From 5bd3832d2736eb6bf09f6813c397d8e866ba4e02 Mon Sep 17 00:00:00 2001
From: Paul Brinkmeier <hallo@pbrinkmeier.de>
Date: Wed, 7 Dec 2022 19:37:39 +0100
Subject: [PATCH] Add simple (and bad) frontend
---
.gitignore | 2 +
Makefile | 2 +
default.nix | 5 +-
elm.json | 28 +++++
elm/Main.elm | 201 ++++++++++++++++++++++++++++++++++++
src/Jon/Garfield/Queries.hs | 16 ++-
src/Jon/Main.hs | 4 +-
src/Jon/Server.hs | 23 ++++-
static/index.html | 15 +++
9 files changed, 286 insertions(+), 10 deletions(-)
create mode 100644 Makefile
create mode 100644 elm.json
create mode 100644 elm/Main.elm
create mode 100644 static/index.html
diff --git a/.gitignore b/.gitignore
index bf51462..75fe1dc 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,5 @@
.stack-work/
.vscode/
.setjonpass
+elm-stuff
+static/jon.js
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..28d3ab4
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,2 @@
+static/jon.js: elm/*.elm $(wildcard elm/**/*.elm)
+ elm make --debug --output static/jon.js elm/Main.elm
diff --git a/default.nix b/default.nix
index 590c536..0d1d24f 100644
--- a/default.nix
+++ b/default.nix
@@ -11,8 +11,11 @@ let
# haskell tools
stack
(ghc.ghcWithPackages haskellDeps)
+
+ # elm tools
+ elmPackages.elm
];
in
pkgs.mkShellNoCC {
- nativeBuildInputs = tools;
+ buildInputs = tools;
}
diff --git a/elm.json b/elm.json
new file mode 100644
index 0000000..779b11e
--- /dev/null
+++ b/elm.json
@@ -0,0 +1,28 @@
+{
+ "type": "application",
+ "source-directories": [
+ "elm"
+ ],
+ "elm-version": "0.19.1",
+ "dependencies": {
+ "direct": {
+ "NoRedInk/elm-json-decode-pipeline": "1.0.1",
+ "elm/browser": "1.0.2",
+ "elm/core": "1.0.5",
+ "elm/html": "1.0.0",
+ "elm/http": "2.0.0",
+ "elm/json": "1.1.3"
+ },
+ "indirect": {
+ "elm/bytes": "1.0.8",
+ "elm/file": "1.0.5",
+ "elm/time": "1.0.0",
+ "elm/url": "1.0.0",
+ "elm/virtual-dom": "1.0.3"
+ }
+ },
+ "test-dependencies": {
+ "direct": {},
+ "indirect": {}
+ }
+}
diff --git a/elm/Main.elm b/elm/Main.elm
new file mode 100644
index 0000000..9bbb252
--- /dev/null
+++ b/elm/Main.elm
@@ -0,0 +1,201 @@
+module Main exposing (..)
+
+import Browser
+import Html exposing (..)
+import Html.Attributes exposing (..)
+import Html.Events exposing (..)
+import Http
+import Json.Decode as Dec
+import Json.Decode.Pipeline exposing (..)
+import Json.Encode as Enc
+import Set exposing (Set)
+
+main = Browser.element
+ { init = \() -> (init, getUnsoundBarcodes loc)
+ , subscriptions = \_ -> Sub.none
+ , update = update
+ , view = view
+ }
+
+getUnsoundBarcodes : Int -> Cmd Msg
+getUnsoundBarcodes location = Http.post
+ { url = "/rpc/getUnsoundBarcodes"
+ , body = Http.jsonBody (Enc.object [("location", Enc.int location)])
+ , expect = Http.expectJson RcvUnsoundBarcodes <| Dec.list (Dec.map3 UnsoundBarcode
+ (Dec.field "barcode" Dec.string)
+ (Dec.field "name" Dec.string)
+ (Dec.field "entries" Dec.int))
+ }
+
+getActiveItems : String -> Int -> Cmd Msg
+getActiveItems barcode location = Http.post
+ { url = "/rpc/getActiveItems"
+ , body = Http.jsonBody (Enc.object
+ [ ("barcode", Enc.string barcode)
+ , ("location", Enc.int location)
+ ])
+ , expect = Http.expectJson (RcvActiveItems barcode) <| Dec.list decodeOI
+ }
+
+transferInventory : List { from : Int, to : Int, amount : Int } -> Cmd Msg
+transferInventory transfers = Http.post
+ { url = "/rpc/transferInventory"
+ , body = Http.jsonBody (Enc.object
+ [ ("transfers", Enc.list encodeTransfer transfers)
+ ])
+ , expect = Http.expectWhatever RcvTransferResponse
+ }
+
+encodeTransfer t = Enc.object
+ [ ("from", Enc.int t.from)
+ , ("to", Enc.int t.to)
+ , ("amount", Enc.int t.amount)
+ ]
+
+disableItems : List Int -> Cmd Msg
+disableItems ids = Http.post
+ { url = "/rpc/disableItems"
+ , body = Http.jsonBody (Enc.object
+ [ ("items", Enc.list Enc.int ids)
+ ])
+ , expect = Http.expectWhatever RcvDisableItemResponse
+ }
+
+decodeOI = Dec.succeed OverviewItem
+ |> requiredAt ["item", "id"] Dec.int
+ |> requiredAt ["item", "barcode"] Dec.string
+ |> requiredAt ["item", "name"] Dec.string
+ |> requiredAt ["overview", "unitsLeft"] Dec.int
+ |> requiredAt ["item", "unitPrice"] Dec.float
+ |> requiredAt ["item", "bought"] Dec.string
+ |> requiredAt ["overview", "activeMappings"] Dec.int
+
+type alias UnsoundBarcode =
+ { barcode : String
+ , name : String
+ , entries : Int
+ }
+
+type alias OverviewItem =
+ { id : Int
+ , barcode : String
+ , name : String
+ , unitsLeft : Int
+ , price : Float
+ , bought : String
+ , activeMappings : Int
+ }
+
+type Model
+ = Init
+ | UBList (List UnsoundBarcode)
+ | Overview String (Set Int) (List OverviewItem)
+
+type Msg
+ = RcvUnsoundBarcodes (Result Http.Error (List UnsoundBarcode))
+ | GetActiveItems String Int
+ | RcvActiveItems String (Result Http.Error (List OverviewItem))
+ | SetSelected Int Bool
+ | TransferInventory (List { amount : Int, from : Int, to : Int })
+ | RcvTransferResponse (Result Http.Error ())
+ | DisableItem Int
+ | RcvDisableItemResponse (Result Http.Error ())
+ | GoBack
+
+init = Init
+loc = 2
+
+update msg model = case model of
+ Init -> case msg of
+ RcvUnsoundBarcodes (Ok ubs) -> (UBList ubs, Cmd.none)
+ _ -> (model, Cmd.none)
+ UBList _ -> case msg of
+ GetActiveItems barcode location -> (model, getActiveItems barcode location)
+ RcvActiveItems barcode (Ok ois) -> (Overview barcode (Set.empty) ois, Cmd.none)
+ _ -> (model, Cmd.none)
+ Overview barcode selectedItems ois -> case msg of
+ SetSelected id checked -> (Overview barcode ((if checked then Set.insert else Set.remove) id selectedItems) ois, Cmd.none)
+ TransferInventory transfers -> (model, transferInventory transfers)
+ RcvTransferResponse _ -> (model, getActiveItems barcode loc)
+ RcvActiveItems barcode_ (Ok ois_) -> (Overview barcode_ (Set.empty) ois_, Cmd.none)
+ DisableItem id -> (model, disableItems [id])
+ RcvDisableItemResponse _ -> (model, getActiveItems barcode loc)
+ GoBack -> (model, getUnsoundBarcodes loc)
+ RcvUnsoundBarcodes (Ok ubs) -> (UBList ubs, Cmd.none)
+ _ -> (model, Cmd.none)
+
+view model = case model of
+ Init -> h1 [] [ text "It works!" ]
+ UBList ubs -> viewUBList ubs
+ Overview barcode selectedItems ois -> viewOverview barcode selectedItems ois
+
+viewUBList ubs =
+ let
+ header = tr []
+ [ th [] [ text "Barcode" ]
+ , th [] [ text "Artikel" ]
+ , th [] [ text "Einträge" ]
+ , th [] [ text "Aktionen" ]
+ ]
+ viewUB ub = tr []
+ [ td [] [ text ub.barcode ]
+ , td [] [ text ub.name ]
+ , td [] [ text <| String.fromInt ub.entries ]
+ , td [] [ button [ onClick (GetActiveItems ub.barcode loc) ] [ text "Einträge ansehen" ] ]
+ ]
+ in
+ table [] ([header] ++ List.map viewUB ubs)
+
+viewOverview : String -> Set Int -> List OverviewItem -> Html Msg
+viewOverview barcode selectedItems ois =
+ let
+ sumSelected =
+ List.sum
+ <| List.map (\oi -> oi.unitsLeft)
+ <| List.filter (\oi -> Set.member oi.id selectedItems) ois
+
+ header = tr []
+ [ th [] []
+ , th [] [ text "ID" ]
+ , th [] [ text "Barcode" ]
+ , th [] [ text "Artikel" ]
+ , th [] [ text "Kaufdatum" ]
+ , th [] [ text "Inventar (Soll)" ]
+ , th [] [ text "Preis" ]
+ , th [] [ text "Snackeinträge" ]
+ , th [] [ text "Aktionen" ]
+ ]
+ viewOI oi = tr []
+ [ th [] [ input [ type_ "checkbox", onCheck <| SetSelected oi.id, selected <| Set.member oi.id selectedItems ] [] ]
+ , td [] [ text <| String.fromInt oi.id ]
+ , td [] [ text oi.barcode ]
+ , td [] [ text oi.name ]
+ , td [] [ text oi.bought ]
+ , td [] [ text <| String.fromInt oi.unitsLeft ]
+ , td [] [ text <| String.fromFloat oi.price ]
+ , td [] [ text <| String.fromInt oi.activeMappings ]
+ , td [] (viewButtons oi)
+ ]
+ viewButtons oi =
+ [ button
+ [ disabled <| Set.member oi.id selectedItems || sumSelected == 0
+ , onClick <| mkTransferMessage selectedItems oi.id
+ ]
+ [ text <| String.fromInt sumSelected ++ " Einträge umbuchen" ]
+ , button
+ [ disabled <| oi.unitsLeft /= 0 || oi.activeMappings /= 0
+ , onClick <| DisableItem oi.id
+ ]
+ [ text "Eintrag deaktivieren" ]
+ ]
+ mkTransferMessage fromIds toId =
+ TransferInventory
+ <| List.map (\oi -> { amount = oi.unitsLeft, from = oi.id, to = toId })
+ <| List.filter (\oi -> Set.member oi.id fromIds) ois
+
+ in
+ div []
+ [ button [ onClick GoBack ] [ text "Zurück" ]
+ , h2 [] [ text barcode ]
+ , table [] ([header] ++ List.map viewOI ois)
+ ]
diff --git a/src/Jon/Garfield/Queries.hs b/src/Jon/Garfield/Queries.hs
index 45167a6..ab95ee1 100644
--- a/src/Jon/Garfield/Queries.hs
+++ b/src/Jon/Garfield/Queries.hs
@@ -70,11 +70,11 @@ locations = all_ garfieldDb.locations
-- Inserts
-runIns
+runInserts
:: Connection
- -> SqlInsert Postgres table
+ -> [SqlInsert Postgres table]
-> IO ()
-runIns conn i = runBeamPostgresDebug putStrLn conn $ runInsert i
+runInserts conn is = runBeamPostgresDebug putStrLn conn $ mapM_ runInsert is
transfer
:: InventoryItemId -- ^ to
@@ -97,6 +97,16 @@ transfer from to amount
(val_ $ Text.pack $ printf "Umbuchung von %d" $ from.unInventoryItemId)
]
+-- Updates
+
+runUpdates :: Connection -> [SqlUpdate Postgres table] -> IO ()
+runUpdates conn us = runBeamPostgresDebug putStrLn conn $ mapM_ runUpdate us
+
+disableItem :: InventoryItemId -> SqlUpdate Postgres InventoryItemT
+disableItem itemId = update (inventoryItems garfieldDb)
+ (\it -> it.available <-. val_ False)
+ (\it -> it.id ==. val_ itemId.unInventoryItemId)
+
-- Function calls
type SqlFunction a = Connection -> IO a
diff --git a/src/Jon/Main.hs b/src/Jon/Main.hs
index db854f1..8e17d7b 100644
--- a/src/Jon/Main.hs
+++ b/src/Jon/Main.hs
@@ -24,9 +24,9 @@ import Jon.Server (JonAPI, jonSwaggerDoc, server)
main :: IO ()
main = withGarfieldConn $ \conn ->
- run 8080 $ serve p $ server conn :<|> swaggerSchemaUIServer jonSwaggerDoc
+ run 8080 $ serve p $ server conn :<|> swaggerSchemaUIServer jonSwaggerDoc :<|> serveDirectoryFileServer "./static"
where
- p :: Proxy (JonAPI :<|> SwaggerSchemaUI "swagger" "swagger.json")
+ p :: Proxy (JonAPI :<|> SwaggerSchemaUI "swagger" "swagger.json" :<|> Raw)
p = Proxy
withGarfieldConn :: (Connection -> IO a) -> IO a
diff --git a/src/Jon/Server.hs b/src/Jon/Server.hs
index 151f4bd..8634477 100644
--- a/src/Jon/Server.hs
+++ b/src/Jon/Server.hs
@@ -49,6 +49,9 @@ type JonAPI =
:> Description "If `amount` is negative, its absolute value is transferred in the opposite direction."
:> ReqBody '[JSON] TransferInventoryP
:> PostNoContent
+ :<|> "disableItems" :> Summary "Disable inventory items"
+ :> ReqBody '[JSON] DisableItemsP
+ :> PostNoContent
:<|> SnackAPI
)
@@ -88,11 +91,19 @@ data GetActiveItemsP = GetActiveItemsP
} deriving (Generic, FromJSON, ToSchema)
data TransferInventoryP = TransferInventoryP
+ { transfers :: [InventoryTransferDTO]
+ } deriving (Generic, FromJSON, ToSchema)
+
+data InventoryTransferDTO = InventoryTransfer
{ from :: InventoryItemId
, to :: InventoryItemId
, amount :: Int64
} deriving (Generic, FromJSON, ToSchema)
+data DisableItemsP = DisableItemsP
+ { items :: [InventoryItemId]
+ } deriving (Generic, FromJSON, ToSchema)
+
data CreateSnackP = CreateSnackP
{ name :: Text
, barcode :: Text
@@ -163,6 +174,7 @@ server conn =
:<|> getActiveItems
:<|> getLocations
:<|> transferInventory
+ :<|> disableItems
:<|> createSnack
:<|> updateSnack
where
@@ -187,11 +199,14 @@ server conn =
getLocations = do
liftIO $ Queries.runSelect conn Queries.locations
+ transferInventory :: TransferInventoryP -> Handler NoContent
transferInventory params = do
- liftIO $ Queries.runIns conn $ Queries.transfer
- params.from
- params.to
- params.amount
+ liftIO $ Queries.runInserts conn $ map (\t -> Queries.transfer t.from t.to t.amount) params.transfers
+ pure NoContent
+
+ disableItems :: DisableItemsP -> Handler NoContent
+ disableItems params = do
+ liftIO $ Queries.runUpdates conn $ map Queries.disableItem params.items
pure NoContent
createSnack params = do
diff --git a/static/index.html b/static/index.html
new file mode 100644
index 0000000..d3fd93d
--- /dev/null
+++ b/static/index.html
@@ -0,0 +1,15 @@
+<!DOCTYPE html>
+<html>
+<head>
+ <meta charset="UTF-8">
+ <link rel="stylesheet" href="./jon.css">
+</head>
+<body>
+ <div class="jon-elm"></div>
+ <!-- Compiled by Elm -->
+ <script src="./jon.js"></script>
+ <script>
+ Elm.Main.init({ node: document.querySelector('.jon-elm') });
+ </script>
+</body>
+</html>