Add simple (and bad) frontend

.gitignore

@@ -1,3 +1,5 @@
 .stack-work/
 .vscode/
 .setjonpass
+elm-stuff
+static/jon.js

Makefile

@@ -0,0 +1,2 @@
+static/jon.js: elm/*.elm $(wildcard elm/**/*.elm)
+	elm make --debug --output static/jon.js elm/Main.elm

default.nix

@@ -11,8 +11,11 @@ let
     # haskell tools
     stack
     (ghc.ghcWithPackages haskellDeps)
+    
+    # elm tools
+    elmPackages.elm
   ];
 in
   pkgs.mkShellNoCC {
-    nativeBuildInputs = tools;
+    buildInputs = tools;
   }

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": {}
+    }
+}

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)
+            ]

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

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

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

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>