Compare commits

...

4 Commits

Author SHA1 Message Date
2045496ef4 Move TODO to README 2023-08-11 14:39:49 +02:00
fd02d162aa Move Python code into repo root 2023-08-11 14:37:51 +02:00
b729e91aaa Remove Haskell code 2023-08-11 14:35:55 +02:00
3ad649a402 Add /inventory/report route 2023-08-11 14:34:57 +02:00
56 changed files with 92 additions and 1885 deletions

6
.gitignore vendored
View File

@ -1,8 +1,4 @@
.stack-work/
.vscode/ .vscode/
.setjonpass
elm-stuff
static/jon.js
__pycache__ __pycache__
*.swp *.swp
py/jon/config.json jon/config.json

View File

@ -1,7 +0,0 @@
Copyright 2022 Paul Brinkmeier
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

View File

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

View File

@ -1,8 +1,20 @@
# jon # jon
> the tamer of garfield > the tamer of garfield
## fsmi-db forward ## fsmi-db forward
``` ```
ssh -nNTvL 5432:fsmi-db.fsmi.uni-karlsruhe.de:5432 fsmi-login ssh -nNTvL 5432:fsmi-db.fsmi.uni-karlsruhe.de:5432 fsmi-login.fsmi.uni-karlsruhe.de
``` ```
## TODO
- [ ] Implement item and snack entry as Elm application
- [ ] Needs good documentation for maintainability
- [ ] Implement and document report generation
- [ ] How many days will the item last?
- [ ] How many do we need to last X months?
- [ ] etc.
- [ ] Make it print nicely
- [ ] Make it possible to edit entries

View File

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

View File

@ -1,3 +0,0 @@
module Main (main) where
import Jon.Main (main)

View File

@ -1,21 +0,0 @@
{ pkgs ? import ./nix/pkgs.nix {} }:
let
ghc = import ./nix/ghc924.nix pkgs;
haskellDeps = import ./nix/haskell-deps.nix;
tools = with pkgs; [
# nix tools
niv
nix-tree
# haskell tools
stack
(ghc.ghcWithPackages haskellDeps)
# elm tools
elmPackages.elm
];
in
pkgs.mkShellNoCC {
buildInputs = tools;
}

View File

@ -1,28 +0,0 @@
{
"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": {}
}
}

View File

@ -1,425 +0,0 @@
module Main exposing (..)
import Browser
import Dict exposing (Dict)
import Html exposing (..)
import Html.Attributes exposing
( checked
, disabled
, style
, type_
, value
)
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.document
{ init = \() -> init
, subscriptions = \_ -> Sub.none
, update = update
, view = \outerState -> { title = "jon", body = [ view outerState ] }
}
getOverviewItems : Int -> Cmd Msg
getOverviewItems location = Http.post
{ url = "/rpc/getOverviewItems"
, body = Http.jsonBody <| Enc.object
[ ("location", Enc.int location)
]
, expect = Http.expectJson RcvOverview <| Dec.list decodeOI
}
rpc : { func : String, args : Enc.Value, expect : Dec.Decoder a } -> (Result Http.Error a -> b) -> Cmd b
rpc { func, args, expect } mkMsg = Http.post
{ url = "/rpc/" ++ func
, body = Http.jsonBody args
, expect = Http.expectJson mkMsg expect
}
getLocations : Cmd Msg
getLocations = rpc
{ func = "getLocations"
, args = Enc.object []
, expect = Dec.list (Dec.succeed Location
|> required "id" Dec.int
|> required "name" Dec.string)
} RcvLocations
adjustInventory : Int -> Int -> String -> Cmd Msg
adjustInventory itemId adjustment description = Http.post
{ url = "/rpc/adjustInventory"
, body = Http.jsonBody <| Enc.object
[ ("item", Enc.int itemId)
, ("amount", Enc.int adjustment)
, ("description", Enc.string description)
]
, expect = Http.expectWhatever (\_ -> RcvOther)
}
type alias InventoryTransferDTO = { from : Int, to : Int, amount : Int }
transferInventory : List InventoryTransferDTO -> Cmd Msg
transferInventory transfers = Http.post
{ url = "/rpc/transferInventory"
, body = Http.jsonBody (Enc.object
[ ("transfers", Enc.list encodeTransfer transfers)
])
, expect = Http.expectWhatever (\_ -> RcvOther)
}
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 (\_ -> RcvOther)
}
deleteSnack : Int -> Cmd Msg
deleteSnack snack = Http.post
{ url = "/rpc/deleteSnack"
, body = Http.jsonBody (Enc.object
[ ("snack", Enc.int snack)
])
, expect = Http.expectWhatever (\_ -> RcvOther)
}
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
|> requiredAt ["item", "group"] Dec.int
|> requiredAt ["overview", "groupName"] Dec.string
getSnacksByItem : OverviewItem -> Cmd Msg
getSnacksByItem item = rpc
{ func = "getSnacksByItemId"
, args = Enc.object
[ ("item", Enc.int item.id)
]
, expect = Dec.list decodeSnack
} (RcvSnacks item)
type alias Snack =
{ id : Int
, name : String
, barcode : String
, price : Float
, location : Int
, taxGroup : Int
}
decodeSnack = Dec.succeed Snack
|> required "id" Dec.int
|> required "name" Dec.string
|> required "barcode" Dec.string
|> required "price" Dec.float
|> required "location" Dec.int
|> required "taxGroup" Dec.int
type alias OverviewItem =
{ id : Int
, barcode : String
, name : String
, unitsLeft : Int
, price : Float
, bought : String
, activeMappings : Int
, groupId : Int
, groupName : String
}
type alias Location =
{ id : Int
, name : String
}
type OuterState
= LoadingLocations
| LocationSelector (List Location)
| Initialized { locations : List Location, location : Location } State
type State
= Overview
{ selectedItems : Set Int
, desiredInventory : Dict Int Int
, overviewItems : List OverviewItem
}
| ViewingItem
{ item : OverviewItem
, snacks : List Snack
}
type Msg
= SelectLocation Location
| SelectItem Int Bool
| ChangeLocation
| SetDesiredInventory Int String
| TransferInventory Int
| GoBack
-- RPC calls
| CallDisableItems (List Int)
| CallAdjustInventory Int Int String
| CallGetSnacksById OverviewItem
| CallDeleteSnack Int
-- Responses
| RcvLocations (Result Http.Error (List Location))
| RcvOverview (Result Http.Error (List OverviewItem))
| RcvSnacks OverviewItem (Result Http.Error (List Snack))
| RcvOther
init = (LoadingLocations, getLocations)
update msg outerState = case msg of
CallAdjustInventory item amount desc -> (outerState, adjustInventory item amount desc)
CallDisableItems items -> (outerState, disableItems items)
CallGetSnacksById item -> (outerState, getSnacksByItem item)
CallDeleteSnack snack -> (outerState, deleteSnack snack)
_ -> case outerState of
LoadingLocations -> case msg of
RcvLocations (Ok locations) ->
(LocationSelector locations, Cmd.none)
_ ->
(outerState, Cmd.none)
LocationSelector locations -> case msg of
SelectLocation location ->
(Initialized { locations = locations, location = location } <| Overview
{ selectedItems = Set.empty
, desiredInventory = Dict.empty
, overviewItems = []
}
, getOverviewItems location.id
)
_ ->
(outerState, Cmd.none)
Initialized global state -> case msg of
ChangeLocation ->
(LocationSelector global.locations, Cmd.none)
_ ->
let
(newState, cmd) = stateMachine msg global state
in
(Initialized global newState, cmd)
stateMachine msg global state = case state of
Overview model -> case msg of
RcvOverview (Ok overviewItems) ->
(Overview
{ selectedItems = Set.empty
, desiredInventory = Dict.empty
, overviewItems = overviewItems
}
, Cmd.none
)
RcvSnacks item (Ok snacks) ->
(ViewingItem { item = item, snacks = snacks }, Cmd.none)
RcvOther ->
(state, getOverviewItems global.location.id)
SelectItem itemId selected ->
(Overview { model | selectedItems = setSelect itemId selected model.selectedItems }, Cmd.none)
SetDesiredInventory itemId invStr -> case String.toInt invStr of
Just inv ->
(Overview { model | desiredInventory = Dict.insert itemId inv model.desiredInventory }, Cmd.none)
Nothing ->
(state, Cmd.none)
TransferInventory targetId ->
let
transfers =
model.overviewItems
|> List.filterMap (\oi ->
if Set.member oi.id model.selectedItems
then Just { from = oi.id, to = targetId, amount = oi.unitsLeft }
else Nothing)
in
(state, transferInventory transfers)
_ ->
(state, Cmd.none)
ViewingItem { item } -> case msg of
GoBack ->
(Overview { selectedItems = Set.empty, desiredInventory = Dict.empty, overviewItems = [] }, getOverviewItems global.location.id)
RcvSnacks item_ (Ok snacks) ->
(ViewingItem { item = item_, snacks = snacks }, Cmd.none)
RcvOther ->
(state, getSnacksByItem item)
_ ->
(state, Cmd.none)
view outerState = case outerState of
LoadingLocations -> progress [] []
LocationSelector locations ->
let
viewLocationButton location =
button [ onClick <| SelectLocation location ] [ text location.name ]
in
div []
[ p [] [ text "Raum auswählen:" ]
, div [] <| List.map viewLocationButton locations
]
Initialized global state ->
div []
[ h2 []
[ text <| "Inventar " ++ global.location.name ++ " "
, button [ onClick ChangeLocation ] [ text "Raum ändern" ]
]
, viewState global state
]
viewState global state = case state of
Overview { selectedItems, desiredInventory, overviewItems } ->
let
header = tableCells th <| List.map text [ "", "ID", "Artikel", "EAN", "Preis", "Kaufdatum", "Snackeinträge", "Inventar", "Aktionen" ]
viewOverviewItem oi =
let
adjustedInventory = Maybe.withDefault oi.unitsLeft <| Dict.get oi.id desiredInventory
mkAdjustInventoryMsg itemId adjustment =
if adjustment > 0
then CallAdjustInventory itemId adjustment "Gewinn"
else CallAdjustInventory itemId adjustment "Verlust"
viewAdjustedInventory adjustment =
if adjustment == 0
then ""
else if adjustment > 0
then "(+" ++ String.fromInt adjustment ++ ")"
else "(" ++ String.fromInt adjustment ++ ")"
sumSelected =
overviewItems
|> List.filter (\x -> Set.member x.id selectedItems)
|> List.map .unitsLeft
|> List.sum
in
tableCells td
[ input
[ type_ "checkbox"
, onCheck <| SelectItem oi.id
, checked <| Set.member oi.id selectedItems
] []
, text <| String.fromInt oi.id
, text oi.name
, code [] [ text oi.barcode ]
, text <| showEuros oi.price
, text <| Tuple.first <| splitAt 'T' oi.bought
, text <| String.fromInt oi.activeMappings
, input
[ type_ "number"
, onInput <| SetDesiredInventory oi.id
, value <| String.fromInt adjustedInventory
, style "width" "5em"
] []
, div []
[ button
(if adjustedInventory == oi.unitsLeft
then [ disabled True ]
else [ onClick <| mkAdjustInventoryMsg oi.id <| adjustedInventory - oi.unitsLeft ])
[ text <| "Inventar korrigieren" ++ viewAdjustedInventory (adjustedInventory - oi.unitsLeft) ]
, button
(if oi.unitsLeft /= 0
then [ disabled True ]
else [ onClick <| CallDisableItems [oi.id] ])
[ text "Eintrag deaktivieren" ]
, button
(if Set.member oi.id selectedItems || sumSelected == 0
then [ disabled True ]
else [ onClick <| TransferInventory oi.id ])
[ text <| String.fromInt sumSelected ++ " Einheiten umbuchen" ]
, button [ onClick <| CallGetSnacksById oi ] [ text "Anzeigen" ]
]
]
in
div []
[ table [] <| [header] ++ List.map viewOverviewItem overviewItems
]
ViewingItem { item, snacks } ->
let
header = tableCells th <| List.map text [ "ID", "Artikel", "Barcode", "Bruttoverkaufspreis", "Aktionen" ]
viewSnack snack = tableCells td
[ text <| String.fromInt snack.id
, text snack.name
, code [] [ text snack.barcode ]
, text <| showEuros snack.price ++ " (+" ++ showEuros (roundTo 2 <| snack.price - item.price) ++ ")"
, div []
[ button [ onClick <| CallDeleteSnack snack.id ] [ text "Deaktivieren" ]
]
]
itemProp label value = tr []
[ th [ style "text-align" "left" ] [ text label ]
, td [] value
]
in
div []
[ button [ onClick GoBack ] [ text "Zurück" ]
, fieldset []
[ legend [] [ text <| "Inventareintrag " ++ String.fromInt item.id ]
, table []
[ tbody []
[ itemProp "ID" [ text <| String.fromInt item.id ]
, itemProp "EAN" [ code [] [ text item.barcode ] ]
, itemProp "Artikel" [ text item.name ]
, itemProp "Gruppe" [ text <| item.groupName ++ " (" ++ String.fromInt item.groupId ++ ")" ]
, itemProp "Inventar" [ text <| String.fromInt item.unitsLeft ]
, itemProp "Kaufdatum" [ text <| Tuple.first <| splitAt 'T' item.bought ]
, itemProp "Nettoeinkaufspreis" [ text <| showEuros item.price ]
]
]
]
, h3 [] [ text "Snacks" ]
, table []
[ thead [] [ header ]
, tbody [] <| List.map viewSnack snacks
]
]
-- utils
tableCells f =
let
mkTd elem = f [] [ elem ]
in
tr [] << List.map mkTd
setSelect elem state =
(if state then Set.insert else Set.remove) elem
splitAt : Char -> String -> (String, String)
splitAt delim str =
let
locate c s = case String.uncons s of
Nothing -> 0
Just (x, xs) ->
if x == c then
0
else
1 + locate c xs
firstOcc = locate delim str
in
(String.slice 0 firstOcc str, String.slice (firstOcc + 1) (String.length str) str)
showEuros : Float -> String
showEuros x =
let
(whole, fractional) = splitAt '.' (String.fromFloat x)
in
whole ++ "," ++ String.slice 0 2 (fractional ++ "00") ++ ""
roundTo : Int -> Float -> Float
roundTo decimals x =
let
m = toFloat <| 10^decimals
in
toFloat (round (x * m)) / m

103
jon.cabal
View File

@ -1,103 +0,0 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.35.0.
--
-- see: https://github.com/sol/hpack
name: jon
version: 0.1.0.0
author: Paul Brinkmeier
maintainer: paul.brinkmeier@fsmi.uni-karlsruhe.de
copyright: 2022 Paul Brinkmeier
license: MIT
license-file: LICENSE
build-type: Simple
extra-source-files:
README.md
source-repository head
type: git
location: https://git.fsmi.org/paul/jon
library
exposed-modules:
Jon.Garfield.Queries
Jon.Garfield.Types
Jon.Main
Jon.Server
other-modules:
Paths_jon
hs-source-dirs:
src
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
build-depends:
aeson
, base >=4.7 && <5
, beam-core
, beam-postgres
, bytestring
, lens
, postgresql-simple
, scientific
, servant
, servant-server
, servant-swagger
, servant-swagger-ui
, swagger2
, text
, time
, warp
default-language: Haskell2010
executable jon-exe
main-is: Main.hs
hs-source-dirs:
app
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
build-depends:
aeson
, base >=4.7 && <5
, beam-core
, beam-postgres
, bytestring
, jon
, lens
, postgresql-simple
, scientific
, servant
, servant-server
, servant-swagger
, servant-swagger-ui
, swagger2
, text
, time
, warp
default-language: Haskell2010
test-suite jon-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Paths_jon
hs-source-dirs:
test
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
build-depends:
aeson
, base >=4.7 && <5
, beam-core
, beam-postgres
, bytestring
, jon
, lens
, postgresql-simple
, scientific
, servant
, servant-server
, servant-swagger
, servant-swagger-ui
, swagger2
, text
, time
, warp
default-language: Haskell2010

View File

@ -0,0 +1,37 @@
WITH
most_recent_sales AS (
SELECT DISTINCT ON (inventory_line)
inventory_line, snack_sales_log_id, snack_sales_log_timestamp AS most_recent_sale
FROM garfield.snack_sales_log
ORDER BY inventory_line ASC, snack_sales_log_timestamp DESC
),
enhanced_overview AS (
SELECT
inventory_items.item_id,
inventory_items.item_barcode,
inventory_items.name,
units_left,
location_name,
location,
CASE
WHEN snack_sales_log_id IS NULL THEN 0
ELSE sales / (EXTRACT(EPOCH FROM most_recent_sale) - EXTRACT(EPOCH FROM bought)) * 24 * 3600
END AS per_day
FROM garfield.inventory_item_overview
LEFT JOIN garfield.inventory_items USING (item_id)
LEFT JOIN most_recent_sales ON item_id = inventory_line
)
SELECT
*,
CASE
WHEN per_day = 0 THEN NULL
ELSE GREATEST(0, units_left / per_day)
END AS days_left,
CASE
WHEN per_day = 0 THEN NULL
ELSE GREATEST(0, (60 - GREATEST(0, units_left / per_day)) * per_day)
END AS for_two_months
FROM enhanced_overview
WHERE (%(location_id)s IS NULL OR location = %(location_id)s)
ORDER BY days_left ASC, per_day DESC

View File

@ -6,7 +6,7 @@ from . import db
bp = Blueprint("inventory", __name__, url_prefix="/inventory") bp = Blueprint("inventory", __name__, url_prefix="/inventory")
@bp.route("/") @bp.get("/")
def index(): def index():
location = session.get("location", None) location = session.get("location", None)
items = db.run_query("get_inventory_overview.sql", { items = db.run_query("get_inventory_overview.sql", {
@ -18,6 +18,18 @@ def index():
}) })
@bp.get("/report")
def read_report():
location = session.get("location", None)
items = db.run_query("get_inventory_report.sql", {
"location_id": None if location is None else location["location_id"]
}).fetchall()
return render_template("inventory/read_report.html", **{
"items": items
})
@bp.get("/item/<item_id>") @bp.get("/item/<item_id>")
def read_item(item_id: int): def read_item(item_id: int):
item = db.run_query("get_item_by_id.sql", { item = db.run_query("get_item_by_id.sql", {

View File

@ -0,0 +1,28 @@
{% extends "base.html" %}
{% block content %}
<table>
<tr>
<th>ID</th>
<th>Barcode</th>
<th>Name</th>
<th>Inventar</th>
<th>Raum</th>
<th>Verbrauch [1/d]</th>
<th>ETUE [d]</th>
<th>Für 2m</th>
</tr>
{% for item in items %}
<tr>
<td><a href="/inventory/item/{{ item.item_id }}">{{ item.item_id }}</a></td>
<td><code>{{ item.item_barcode }}</code></td>
<td>{{ item.name }}</td>
<td class="--align-right">{{ item.units_left }}</td>
<td>{{ item.location_name }}</td>
<td class="--align-right">{{ item.per_day|round(2) }}</td>
<td class="--align-right">{% if item.days_left != None %}{{ item.days_left|round(1) }}{% endif %}</td>
<td class="--align-right">{% if item.for_two_months %}{{ item.for_two_months|round(1) }}{% endif %}</td>
</tr>
{% endfor %}
</table>
{% endblock %}

View File

@ -1,2 +0,0 @@
pkgs:
pkgs.haskell.packages.ghc924

View File

@ -1,17 +0,0 @@
haskellPackages: with haskellPackages; [
aeson
beam-core
beam-postgres
bytestring
lens
postgresql-simple
servant
servant-server
servant-swagger
servant-swagger-ui
scientific
swagger2
text
time
warp
]

View File

@ -1,5 +0,0 @@
{ overlays ? [] }:
let
sources = import ./sources.nix;
in
import sources.nixpkgs { inherit overlays; }

View File

@ -1,26 +0,0 @@
{
"niv": {
"branch": "master",
"description": "Easy dependency management for Nix projects",
"homepage": "https://github.com/nmattia/niv",
"owner": "nmattia",
"repo": "niv",
"rev": "351d8bc316bf901a81885bab5f52687ec8ccab6e",
"sha256": "1yzhz7ihkh6p2sxhp3amqfbmm2yqzaadqqii1xijymvl8alw5rrr",
"type": "tarball",
"url": "https://github.com/nmattia/niv/archive/351d8bc316bf901a81885bab5f52687ec8ccab6e.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"nixpkgs": {
"branch": "nixpkgs-unstable",
"description": "Nix Packages collection",
"homepage": "",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "227de2b3bbec142f912c09d5e8a1b4e778aa54fb",
"sha256": "04is77q4msyqi51q8zxialyl378hzv47ldml5hnycg42zvnzpi24",
"type": "tarball",
"url": "https://github.com/NixOS/nixpkgs/archive/227de2b3bbec142f912c09d5e8a1b4e778aa54fb.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
}
}

View File

@ -1,194 +0,0 @@
# This file has been generated by Niv.
let
#
# The fetchers. fetch_<type> fetches specs of type <type>.
#
fetch_file = pkgs: name: spec:
let
name' = sanitizeName name + "-src";
in
if spec.builtin or true then
builtins_fetchurl { inherit (spec) url sha256; name = name'; }
else
pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
fetch_tarball = pkgs: name: spec:
let
name' = sanitizeName name + "-src";
in
if spec.builtin or true then
builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
else
pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
fetch_git = name: spec:
let
ref =
if spec ? ref then spec.ref else
if spec ? branch then "refs/heads/${spec.branch}" else
if spec ? tag then "refs/tags/${spec.tag}" else
abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";
submodules = if spec ? submodules then spec.submodules else false;
submoduleArg =
let
nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;
emptyArgWithWarning =
if submodules == true
then
builtins.trace
(
"The niv input \"${name}\" uses submodules "
+ "but your nix's (${builtins.nixVersion}) builtins.fetchGit "
+ "does not support them"
)
{}
else {};
in
if nixSupportsSubmodules
then { inherit submodules; }
else emptyArgWithWarning;
in
builtins.fetchGit
({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);
fetch_local = spec: spec.path;
fetch_builtin-tarball = name: throw
''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.
$ niv modify ${name} -a type=tarball -a builtin=true'';
fetch_builtin-url = name: throw
''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`.
$ niv modify ${name} -a type=file -a builtin=true'';
#
# Various helpers
#
# https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695
sanitizeName = name:
(
concatMapStrings (s: if builtins.isList s then "-" else s)
(
builtins.split "[^[:alnum:]+._?=-]+"
((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)
)
);
# The set of packages used when specs are fetched using non-builtins.
mkPkgs = sources: system:
let
sourcesNixpkgs =
import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
hasThisAsNixpkgsPath = <nixpkgs> == ./.;
in
if builtins.hasAttr "nixpkgs" sources
then sourcesNixpkgs
else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then
import <nixpkgs> {}
else
abort
''
Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or
add a package called "nixpkgs" to your sources.json.
'';
# The actual fetching function.
fetch = pkgs: name: spec:
if ! builtins.hasAttr "type" spec then
abort "ERROR: niv spec ${name} does not have a 'type' attribute"
else if spec.type == "file" then fetch_file pkgs name spec
else if spec.type == "tarball" then fetch_tarball pkgs name spec
else if spec.type == "git" then fetch_git name spec
else if spec.type == "local" then fetch_local spec
else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
else if spec.type == "builtin-url" then fetch_builtin-url name
else
abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
# If the environment variable NIV_OVERRIDE_${name} is set, then use
# the path directly as opposed to the fetched source.
replace = name: drv:
let
saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
in
if ersatz == "" then drv else
# this turns the string into an actual Nix path (for both absolute and
# relative paths)
if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";
# Ports of functions for older nix versions
# a Nix version of mapAttrs if the built-in doesn't exist
mapAttrs = builtins.mapAttrs or (
f: set: with builtins;
listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))
);
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295
range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1);
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257
stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1));
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
concatMapStrings = f: list: concatStrings (map f list);
concatStrings = builtins.concatStringsSep "";
# https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
optionalAttrs = cond: as: if cond then as else {};
# fetchTarball version that is compatible between all the versions of Nix
builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchTarball;
in
if lessThan nixVersion "1.12" then
fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
else
fetchTarball attrs;
# fetchurl version that is compatible between all the versions of Nix
builtins_fetchurl = { url, name ? null, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchurl;
in
if lessThan nixVersion "1.12" then
fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
else
fetchurl attrs;
# Create the final "sources" from the config
mkSources = config:
mapAttrs (
name: spec:
if builtins.hasAttr "outPath" spec
then abort
"The values in sources.json should not have an 'outPath' attribute"
else
spec // { outPath = replace name (fetch config.pkgs name spec); }
) config.sources;
# The "config" used by the fetchers
mkConfig =
{ sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
, sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
, system ? builtins.currentSystem
, pkgs ? mkPkgs sources system
}: rec {
# The sources, i.e. the attribute set of spec name to spec
inherit sources;
# The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
inherit pkgs;
};
in
mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }

View File

@ -1,71 +0,0 @@
# Adapted from new-template.hsfiles
name: jon
version: 0.1.0.0
git: "https://git.fsmi.org/paul/jon"
license: MIT
author: "Paul Brinkmeier"
maintainer: "paul.brinkmeier@fsmi.uni-karlsruhe.de"
copyright: "2022 Paul Brinkmeier"
extra-source-files:
- README.md
dependencies:
- base >= 4.7 && < 5
- aeson
- beam-core
- beam-postgres
- bytestring
- lens
- postgresql-simple
- servant
- servant-server
- servant-swagger
- servant-swagger-ui
- scientific
- swagger2
- text
- time
- warp
ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wmissing-export-lists
- -Wmissing-home-modules
- -Wpartial-fields
- -Wredundant-constraints
library:
source-dirs: src
executables:
jon-exe:
main: Main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- jon
# Fix "Multiple files use the same module name", see
# https://stackoverflow.com/questions/67519851/multiple-files-use-the-same-module-name
when:
- condition: false
other-modules: Paths_jon
tests:
jon-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- jon

View File

@ -1 +0,0 @@
- [ ] Fix date handling in entry

View File

@ -1,162 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Jon.Garfield.Queries where
import Data.Int (Int64)
import Data.Scientific (Scientific)
import Data.Text (Text)
import Database.Beam
import Database.Beam.Postgres
import Database.PostgreSQL.Simple
import Text.Printf (printf)
import qualified Data.Text as Text
import Jon.Garfield.Types
-- Selects
runSelect
:: (FromBackendRow Postgres (QExprToIdentity e), Projectible Postgres e)
=> Connection
-> Q Postgres db QBaseScope e
-> IO [QExprToIdentity e]
runSelect conn q = runBeamPostgresDebug putStrLn conn $ runSelectReturningList $ select q
overviewItems
:: Q Postgres GarfieldDb s (OverviewT (QExpr Postgres s), InventoryItemT (QExpr Postgres s))
overviewItems = do
ov <- all_ garfieldDb.overview
it <- related_ garfieldDb.inventoryItems ov.itemId
pure (ov, it)
overviewItemsByLocation
:: LocationId
-> Q Postgres GarfieldDb s (OverviewT (QExpr Postgres s), InventoryItemT (QExpr Postgres s))
overviewItemsByLocation loc = do
row@(_, it) <- overviewItems
guard_ $ it.location ==. val_ loc
pure row
unsoundBarcodes
:: LocationId
-> Q Postgres GarfieldDb s (QExpr Postgres s Text, QExpr Postgres s Text, QExpr Postgres s Int64, QExpr Postgres s Int64)
unsoundBarcodes loc =
filter_ (\(_, _, entries, _) -> entries >=. 2) $
aggregate_
(\(ov, it) ->
( group_ it.barcode
, fromMaybe_ "" $ max_ it.name
, as_ @Int64 countAll_
, as_ @Int64 $ cast_ (sum_ ov.unitsLeft) int
))
(overviewItemsByLocation loc)
activeItems
:: Text -- barcode
-> LocationId
-> Q Postgres GarfieldDb s (OverviewT (QExpr Postgres s), InventoryItemT (QExpr Postgres s))
activeItems barcode loc = do
(ov, it) <- overviewItemsByLocation loc
guard_ $ it.barcode ==. val_ barcode
pure (ov, it)
locations
:: Q Postgres GarfieldDb s (LocationT (QExpr Postgres s))
locations = all_ garfieldDb.locations
getSnacksByItemId
:: InventoryItemId
-> Q Postgres GarfieldDb s (SnackT (QExpr Postgres s))
getSnacksByItemId item = do
im <- all_ garfieldDb.inventoryMap
sn <- related_ garfieldDb.snacks im.snackId
sa <- oneToOne_ garfieldDb.snacksAvailable (.snackId) sn
guard_ $ im.inventoryId ==. val_ item
guard_ $ sa.available
pure sn
-- Inserts
runInserts
:: Connection
-> [SqlInsert Postgres table]
-> IO ()
runInserts conn is = runBeamPostgresDebug putStrLn conn $ mapM_ runInsert is
adjustInventory
:: InventoryItemId
-> Int64
-> Text
-> SqlInsert Postgres CorrectionT
adjustInventory item amount desc = insert garfieldDb.inventoryCorrections $
insertExpressions [Correction (val_ item) default_ (val_ amount) (val_ desc)]
transfer
:: InventoryItemId -- ^ to
-> InventoryItemId -- ^ from
-> Int64 -- ^ amount to transfer. If negative, acts like 'transfer b a (-amount)'
-> SqlInsert Postgres CorrectionT
transfer from to amount
| amount < 0 = transfer to from (-amount)
| otherwise = insert garfieldDb.inventoryCorrections $
insertExpressions
[ Correction
(val_ from)
default_
(val_ $ -amount)
(val_ $ Text.pack $ printf "Umbuchung auf %d" $ to.unInventoryItemId)
, Correction
(val_ to)
default_
(val_ 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
runFunction :: Connection -> SqlFunction a -> IO a
runFunction conn f = f conn
snackDelete :: SnackId -> SqlFunction ()
snackDelete snack conn = do
[Only ()] <- query conn "SELECT garfield.snack_delete(?)" (Only $ snack.unSnackId)
pure ()
snackCreate :: Text -> Text -> Scientific -> TaxGroupId -> LocationId -> SqlFunction SnackId
snackCreate name barcode price taxGroup location conn = do
[Only rawSnackId] <- query conn "SELECT garfield.snack_create(?, ?, ?, ?, ?)"
(name, barcode, price, taxGroup.unTaxGroupId, location.unLocationId)
pure $ mkSnackId rawSnackId
snackUpdate
:: SnackId
-> Text -- Name
-> Text -- Barcode
-> Scientific
-> TaxGroupId
-> SqlFunction SnackId
snackUpdate snack name barcode price taxGroup conn = do
[Only rawSnackId] <- query conn "SELECT garfield.snack_update(?, ?, ?, ?, ?)"
(snack.unSnackId, name, barcode, price, taxGroup.unTaxGroupId)
pure $ mkSnackId rawSnackId
inventoryMapSnack :: SnackId -> InventoryItemId -> SqlFunction ()
inventoryMapSnack snack item conn = do
[Only ()] <- query conn "SELECT garfield.inventory_map_snack(?, ?)" (snack.unSnackId, item.unInventoryItemId)
pure ()

View File

@ -1,439 +0,0 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Jon.Garfield.Types
( GarfieldDb(..)
, Correction
, CorrectionId
, CorrectionT(..)
, InventoryItem
, InventoryItemId
, InventoryItemT(..)
, InventoryItemGroup
, InventoryItemGroupId
, InventoryItemGroupT(..)
, InventoryMap
, InventoryMapId
, InventoryMapT(..)
, TaxGroup
, TaxGroupId
, TaxGroupT(..)
, Location
, LocationId
, LocationT(..)
, Overview
, OverviewId
, OverviewT(..)
, Snack
, SnackId
, SnackT(..)
, SnackAvailable
, SnackAvailableId
, SnackAvailableT(..)
, Sale
, SaleId
, SaleT(..)
, User
, UserId
, UserT(..)
, garfieldDb
, mkOverviewId
, mkInventoryItemId
, mkTaxGroupId
, mkLocationId
, mkSaleId
, mkSnackId
, mkSnackAvailableId
, mkUserId
, unOverviewId
, unInventoryItemId
, unInventoryItemGroupId
, unTaxGroupId
, unLocationId
, unSaleId
, unSnackId
, unSnackAvailableId
, unUserId
) where
import Data.Functor.Identity (Identity)
import Data.Int (Int32, Int64)
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Time (UTCTime)
import Database.Beam
( Beamable
, C
, Database
, DatabaseSettings
, Nullable
, PrimaryKey
, Table(primaryKey)
, TableEntity
, TableField
, FieldModification
, dbModification
, defaultDbSettings
, fieldNamed
, modifyTableFields
, setEntityName
, tableModification
, withDbModification
)
import Database.Beam.Schema.Tables (setEntitySchema)
import GHC.Generics (Generic)
-- Garfield
data GarfieldDb f = GarfieldDb
-- views
{ overview :: f (TableEntity OverviewT)
-- tables
, inventoryItems :: f (TableEntity InventoryItemT)
, inventoryItemGroups :: f (TableEntity InventoryItemGroupT)
, taxGroups :: f (TableEntity TaxGroupT)
, locations :: f (TableEntity LocationT)
, inventoryCorrections :: f (TableEntity CorrectionT)
, snacks :: f (TableEntity SnackT)
, sales :: f (TableEntity SaleT)
, users :: f (TableEntity UserT)
, inventoryMap :: f (TableEntity InventoryMapT)
, snacksAvailable :: f (TableEntity SnackAvailableT)
} deriving (Generic, Database be)
setGarfieldEntityName name = setEntitySchema (Just "garfield") <> setEntityName name
type Mod f = f (FieldModification (TableField f))
garfieldDb :: DatabaseSettings be GarfieldDb
garfieldDb = defaultDbSettings `withDbModification`
dbModification
{ overview = setGarfieldEntityName "inventory_item_overview" <> modifyTableFields tableModification
{ itemId = InventoryItemId "item_id"
, salesUnits = "sales_units"
, unitPrice = "unit_price"
, groupName = "group_name"
, unitsLeft = "units_left"
, correctionDelta = "correction_delta"
, activeMappings = "active_mappings"
, locationName = "location_name"
}
, inventoryItems = setGarfieldEntityName "inventory_items" <> modifyTableFields tableModification
{ id = "item_id"
, group = InventoryItemGroupId "item_group"
, bestBefore = "best_before"
, barcode = "item_barcode"
, unitPrice = "unit_price"
, salesUnits = "sales_units"
, taxGroup = TaxGroupId "tax_group"
, location = LocationId "location"
}
, inventoryItemGroups = setGarfieldEntityName "inventory_item_groups" <> modifyTableFields (tableModification :: Mod InventoryItemGroupT)
{ id = "group_id"
, name = "group_name"
}
, taxGroups = setGarfieldEntityName "tax_groups" <> modifyTableFields (tableModification :: Mod TaxGroupT)
{ id = "tax_group_id"
}
, locations = setGarfieldEntityName "locations" <> modifyTableFields tableModification
{ id = "location_id"
, name = "location_name"
, description = "location_description"
}
, inventoryCorrections = setGarfieldEntityName "inventory_correction" <> modifyTableFields tableModification
{ itemId = InventoryItemId "item_id"
, time = "correction_time"
, comment = "correction_comment"
}
, snacks = setGarfieldEntityName "snacks" <> modifyTableFields tableModification
{ id = "snack_id"
, name = "snack_name"
, barcode = "snack_barcode"
, price = "snack_price"
, location = LocationId "location_id"
, timestamp = "snack_timestamp"
, taxGroup = TaxGroupId "tax_group_id"
}
, sales = setGarfieldEntityName "snack_sales_log" <> modifyTableFields tableModification
{ id = "snack_sales_log_id"
, timestamp = "snack_sales_log_timestamp"
, snack = SnackId "snack_id"
, location = LocationId "location_id"
, type' = "type_id"
, grossPrice = "gross_price"
, inventoryItem = InventoryItemId "inventory_line"
}
, users = setGarfieldEntityName "users" <> modifyTableFields tableModification
{ id = "user_id"
, name = "user_name"
, fullName = "user_full_name"
, alwaysSendBalanceMail = "always_send_balance_mail"
, sendHistoryMail = "send_history_mail"
}
, inventoryMap = setGarfieldEntityName "inventory_map" <> modifyTableFields tableModification
{ inventoryId = InventoryItemId "inventory_id"
, snackId = SnackId "snack_id"
}
, snacksAvailable = setGarfieldEntityName "snacks_available" <> modifyTableFields tableModification
{ snackId = SnackId "snack_id"
, available = "snack_available"
}
}
-- Views
data OverviewT f = Overview
{ itemId :: PrimaryKey InventoryItemT f
, name :: C f Text
, salesUnits :: C f Int64
, unitPrice :: C f Scientific
, sales :: C f Scientific
, groupName :: C f Text
, unitsLeft :: C f Scientific
, correctionDelta :: C f Scientific
, activeMappings :: C f Scientific
, locationName :: C f Text
} deriving (Beamable, Generic)
type Overview = OverviewT Identity
type OverviewId = PrimaryKey OverviewT Identity
mkOverviewId :: Int32 -> OverviewId
mkOverviewId = OverviewId
deriving instance Show Overview
deriving instance Show OverviewId
instance Table OverviewT where
data PrimaryKey OverviewT f
= OverviewId { unOverviewId :: C f Int32 } deriving (Beamable, Generic)
primaryKey = OverviewId . unInventoryItemId . (.itemId)
-- Tables
data InventoryItemT f = InventoryItem
{ id :: C f Int32
, available :: C f Bool
, name :: C f Text
, group :: PrimaryKey InventoryItemGroupT f
, bought :: C f UTCTime
, bestBefore :: C f UTCTime
, barcode :: C f Text
, unitPrice :: C f Scientific
, salesUnits :: C f Int64
, taxGroup :: PrimaryKey TaxGroupT f
, location :: PrimaryKey LocationT f
} deriving (Beamable, Generic)
type InventoryItem = InventoryItemT Identity
type InventoryItemId = PrimaryKey InventoryItemT Identity
mkInventoryItemId :: Int32 -> InventoryItemId
mkInventoryItemId = InventoryItemId
deriving instance Show InventoryItem
deriving instance Show InventoryItemId
deriving instance Show (PrimaryKey InventoryItemT (Nullable Identity))
instance Table InventoryItemT where
data PrimaryKey InventoryItemT f
= InventoryItemId { unInventoryItemId :: C f Int32 } deriving (Beamable, Generic)
primaryKey = InventoryItemId . (.id)
data InventoryItemGroupT f = InventoryItemGroup
{ id :: C f Int32
, name :: C f Text
} deriving (Beamable, Generic)
type InventoryItemGroup = InventoryItemGroupT Identity
type InventoryItemGroupId = PrimaryKey InventoryItemGroupT Identity
deriving instance Show InventoryItemGroup
deriving instance Show InventoryItemGroupId
instance Table InventoryItemGroupT where
data PrimaryKey InventoryItemGroupT f
= InventoryItemGroupId { unInventoryItemGroupId :: C f Int32 } deriving (Beamable, Generic)
primaryKey = InventoryItemGroupId . (.id)
data TaxGroupT f = TaxGroup
{ id :: C f Int32
, description :: C f Text
, active :: C f Bool
} deriving (Beamable, Generic)
type TaxGroup = TaxGroupT Identity
type TaxGroupId = PrimaryKey TaxGroupT Identity
mkTaxGroupId = TaxGroupId
deriving instance Show TaxGroup
deriving instance Show TaxGroupId
instance Table TaxGroupT where
data PrimaryKey TaxGroupT f
= TaxGroupId { unTaxGroupId :: C f Int32 } deriving (Beamable, Generic)
primaryKey = TaxGroupId . (.id)
data LocationT f = Location
{ id :: C f Int32
, name :: C f Text
, description :: C f Text
} deriving (Beamable, Generic)
type Location = LocationT Identity
type LocationId = PrimaryKey LocationT Identity
mkLocationId :: Int32 -> LocationId
mkLocationId = LocationId
deriving instance Show Location
deriving instance Show LocationId
instance Table LocationT where
data PrimaryKey LocationT f
= LocationId { unLocationId :: C f Int32 } deriving (Beamable, Generic)
primaryKey = LocationId . (.id)
data CorrectionT f = Correction
{ itemId :: PrimaryKey InventoryItemT f
, time :: C f UTCTime
, delta :: C f Int64
, comment :: C f Text
} deriving (Beamable, Generic)
type Correction = CorrectionT Identity
type CorrectionId = PrimaryKey CorrectionT Identity
deriving instance Show Correction
deriving instance Show CorrectionId
instance Table CorrectionT where
data PrimaryKey CorrectionT f
= CorrectionId deriving (Beamable, Generic)
primaryKey _ = CorrectionId
data SnackT f = Snack
{ id :: C f Int32
, name :: C f Text
, barcode :: C (Nullable f) Text
, price :: C f Scientific
, location :: PrimaryKey LocationT f
-- , snackModifiedBy :: PrimaryKey UserT f
, timestamp :: C (Nullable f) UTCTime
, taxGroup :: PrimaryKey TaxGroupT f
} deriving (Beamable, Generic)
type Snack = SnackT Identity
type SnackId = PrimaryKey SnackT Identity
mkSnackId :: Int32 -> SnackId
mkSnackId = SnackId
deriving instance Show Snack
deriving instance Show SnackId
instance Table SnackT where
data PrimaryKey SnackT f
= SnackId { unSnackId :: C f Int32 } deriving (Beamable, Generic)
primaryKey = SnackId . (.id)
data SaleT f = Sale
{ id :: C f Int32
, timestamp :: C f UTCTime
, snack :: PrimaryKey SnackT f
, location :: PrimaryKey LocationT f
, type' :: C f Text
-- , saleSubtotal :: PrimaryKey SubtotalT f
, grossPrice :: C f Scientific
-- , saleTax :: PrimaryKey TaxT f
, inventoryItem :: PrimaryKey InventoryItemT (Nullable f)
} deriving (Beamable, Generic)
type Sale = SaleT Identity
type SaleId = PrimaryKey SaleT Identity
mkSaleId :: Int32 -> SaleId
mkSaleId = SaleId
deriving instance Show Sale
deriving instance Show SaleId
instance Table SaleT where
data PrimaryKey SaleT f
= SaleId { unSaleId :: C f Int32 } deriving (Beamable, Generic)
primaryKey = SaleId . (.id)
data UserT f = User
{ id :: C f Int32
, name :: C f Text
, fullName :: C f Text
, alwaysSendBalanceMail :: C f Bool
, sendHistoryMail :: C f Bool
} deriving (Beamable, Generic)
type User = UserT Identity
type UserId = PrimaryKey UserT Identity
mkUserId :: Int32 -> UserId
mkUserId = UserId
deriving instance Show User
deriving instance Show UserId
instance Table UserT where
data PrimaryKey UserT f
= UserId { unUserId :: C f Int32 } deriving (Beamable, Generic)
primaryKey = UserId . (.id)
data InventoryMapT f = InventoryMap
{ inventoryId :: PrimaryKey InventoryItemT f
, snackId :: PrimaryKey SnackT f
} deriving (Beamable, Generic)
type InventoryMap = InventoryMapT Identity
type InventoryMapId = PrimaryKey InventoryMapT Identity
deriving instance Show InventoryMap
deriving instance Show InventoryMapId
instance Table InventoryMapT where
data PrimaryKey InventoryMapT f
= InventoryMapId deriving (Beamable, Generic)
primaryKey _ = InventoryMapId
data SnackAvailableT f = SnackAvailable
{ snackId :: PrimaryKey SnackT f
, available :: C f Bool
} deriving (Beamable, Generic)
type SnackAvailable = SnackAvailableT Identity
type SnackAvailableId = PrimaryKey SnackAvailableT Identity
mkSnackAvailableId :: SnackId -> SnackAvailableId
mkSnackAvailableId = SnackAvailableId
deriving instance Show SnackAvailable
deriving instance Show SnackAvailableId
instance Table SnackAvailableT where
data PrimaryKey SnackAvailableT f
= SnackAvailableId { unSnackAvailableId :: PrimaryKey SnackT f } deriving (Beamable, Generic)
primaryKey = SnackAvailableId . (.snackId)

View File

@ -1,32 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Jon.Main
( main
) where
import Control.Exception (bracket)
import Database.Beam.Postgres
import Servant
import Servant.Swagger.UI
import System.Environment
import Network.Wai.Handler.Warp (run)
import qualified Data.ByteString.Char8 as BS8
import Jon.Server (JonAPI, jonSwaggerDoc, server)
main :: IO ()
main = withGarfieldConn $ \conn ->
run 8080 $ serve p (server conn :<|> swaggerSchemaUIServer jonSwaggerDoc :<|> serveDirectoryFileServer "./static")
where
p :: Proxy (JonAPI :<|> SwaggerSchemaUI "swagger" "swagger.json" :<|> Raw)
p = Proxy
withGarfieldConn :: (Connection -> IO a) -> IO a
withGarfieldConn = bracket
(do pass <- getEnv "JON_PASS"
connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass)
close

View File

@ -1,273 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Jon.Server (JonAPI, jonSwaggerDoc, server) where
import Control.Lens
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))
import Data.Text (Text)
import Data.Int (Int32, Int64)
import Data.Scientific (Scientific)
import Data.Swagger
import Database.PostgreSQL.Simple (Connection)
import GHC.Generics (Generic)
import Servant
import Servant.Swagger (toSwagger)
import Jon.Garfield.Types
import qualified Jon.Garfield.Queries as Queries
-- API and types
type JonAPI =
"rpc" :>
( "getUnsoundBarcodes" :> Summary "Get information on barcodes with at least two items"
:> ReqBody '[JSON] GetUnsoundBarcodesP
:> Post '[JSON] [UnsoundBarcodeDTO]
:<|> "getOverviewItems" :> Summary "Get overview of all active items"
:> ReqBody '[JSON] GetOverviewItemsP
:> Post '[JSON] [OverviewItemDTO]
:<|> "getActiveItems" :> Summary "Get currently active items for a barcode"
:> ReqBody '[JSON] GetActiveItemsP
:> Post '[JSON] [OverviewItemDTO]
:<|> "getLocations" :> Summary "Get a list of all locations"
:> Post '[JSON] [Location]
:<|> "adjustInventory" :> ReqBody '[JSON] AdjustInventoryP
:> PostNoContent
:<|> "transferInventory" :> Summary "Transfer inventory between items"
:> 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
)
type SnackAPI =
"createSnack" :> Summary "Create a snack"
:> ReqBody '[JSON] CreateSnackP
:> Post '[JSON] SnackId
:<|> "getSnacksByItemId" :> Summary "Get active snacks by item id"
:> ReqBody '[JSON] GetSnacksByItemIdP
:> Post '[JSON] [Snack]
:<|> "updateSnack" :> Summary "Update a snack"
:> ReqBody '[JSON] UpdateSnackP
:> Post '[JSON] SnackId
:<|> "deleteSnack" :> Summary "Delete a snack"
:> ReqBody '[JSON] DeleteSnackP
:> PostNoContent
data GetUnsoundBarcodesP = GetUnsoundBarcodesP
{ location :: LocationId
} deriving (Generic, FromJSON, ToSchema)
data UnsoundBarcodeDTO = UnsoundBarcodeDTO
{ barcode :: Text
, name :: Text
, entries :: Int
, unitsLeft :: Int
} deriving (Generic, ToJSON, ToSchema)
data GetOverviewItemsP = GetOverviewItemsP
{ location :: LocationId
} deriving (Generic, FromJSON, ToSchema)
data OverviewItemDTO = OverviewItemDTO
{ overview :: Overview
, item :: InventoryItem
} deriving (Generic, ToJSON, ToSchema)
mkOverviewItemDTO = uncurry OverviewItemDTO
data GetActiveItemsP = GetActiveItemsP
{ barcode :: Text
, location :: LocationId
} deriving (Generic, FromJSON, ToSchema)
data AdjustInventoryP = AdjustInventoryP
{ item :: InventoryItemId
, amount :: Int64
, description :: Text
} 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
, price :: Scientific
, taxGroup :: TaxGroupId
, location :: LocationId
} deriving (Generic, FromJSON, ToSchema)
data GetSnacksByItemIdP = GetSnacksByItemIdP
{ item :: InventoryItemId
} deriving (Generic, FromJSON, ToSchema)
data UpdateSnackP = UpdateSnackP
{ snack :: SnackId
, name :: Text
, barcode :: Text
, price :: Scientific
, taxGroup :: TaxGroupId
} deriving (Generic, FromJSON, ToSchema)
data DeleteSnackP = DeleteSnackP
{ snack :: SnackId
} deriving (Generic, FromJSON, ToSchema)
-- Orphan instances for database types
-- needed for serialization and swagger doc
instance ToJSON InventoryItemId where
toJSON = toJSON . (.unInventoryItemId)
instance FromJSON InventoryItemId where
parseJSON = fmap mkInventoryItemId . parseJSON
instance ToSchema InventoryItemId where
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32)
instance ToJSON InventoryItemGroupId where
toJSON = toJSON . (.unInventoryItemGroupId)
instance ToSchema InventoryItemGroupId where
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32)
instance ToJSON TaxGroupId where
toJSON = toJSON . (.unTaxGroupId)
instance FromJSON TaxGroupId where
parseJSON = fmap mkTaxGroupId . parseJSON
instance ToSchema TaxGroupId where
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32)
instance ToJSON LocationId where
toJSON = toJSON . (.unLocationId)
instance FromJSON LocationId where
parseJSON = fmap mkLocationId . parseJSON
instance ToSchema LocationId where
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32)
instance ToJSON SnackId where
toJSON = toJSON . (.unSnackId)
instance FromJSON SnackId where
parseJSON = fmap mkSnackId . parseJSON
instance ToSchema SnackId where
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32)
deriving instance ToJSON Overview
deriving instance ToSchema Overview
deriving instance ToJSON InventoryItem
deriving instance ToSchema InventoryItem
deriving instance ToJSON Location
deriving instance ToSchema Location
deriving instance ToJSON Snack
deriving instance ToSchema Snack
-- server
server :: Connection -> Server JonAPI
server conn =
getUnsoundBarcodes
:<|> getOverviewItems
:<|> getActiveItems
:<|> getLocations
:<|> adjustInventory
:<|> transferInventory
:<|> disableItems
:<|> createSnack
:<|> getSnacksByItemId
:<|> updateSnack
:<|> deleteSnack
where
getUnsoundBarcodes :: GetUnsoundBarcodesP -> Handler [UnsoundBarcodeDTO]
getUnsoundBarcodes params = do
rows <- liftIO $ Queries.runSelect conn $ Queries.unsoundBarcodes params.location
pure $ map mkUnsoundBarcodeDTO rows
where
mkUnsoundBarcodeDTO (a, b, c, d) = UnsoundBarcodeDTO a b (fromIntegral c) (fromIntegral d)
getOverviewItems :: GetOverviewItemsP -> Handler [OverviewItemDTO]
getOverviewItems params = do
rows <- liftIO $ Queries.runSelect conn $ Queries.overviewItemsByLocation params.location
pure $ map mkOverviewItemDTO rows
getActiveItems :: GetActiveItemsP -> Handler [OverviewItemDTO]
getActiveItems params = do
rows <- liftIO $ Queries.runSelect conn $ Queries.activeItems params.barcode params.location
pure $ map mkOverviewItemDTO rows
getLocations :: Handler [Location]
getLocations = do
liftIO $ Queries.runSelect conn Queries.locations
adjustInventory params = do
liftIO $ Queries.runInserts conn [Queries.adjustInventory params.item params.amount params.description]
pure NoContent
transferInventory :: TransferInventoryP -> Handler NoContent
transferInventory params = do
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
liftIO $ Queries.runFunction conn $ Queries.snackCreate
params.name
params.barcode
params.price
params.taxGroup
params.location
getSnacksByItemId params = do
liftIO $ Queries.runSelect conn $ Queries.getSnacksByItemId params.item
updateSnack params = do
liftIO $ Queries.runFunction conn $ Queries.snackUpdate
params.snack
params.name
params.barcode
params.price
params.taxGroup
deleteSnack params = do
liftIO $ Queries.runFunction conn $ Queries.snackDelete params.snack
pure NoContent
jonSwaggerDoc :: Swagger
jonSwaggerDoc = toSwagger (Proxy :: Proxy JonAPI)
& info . title .~ "jon API"
& info . version .~ "0.1.1"
& applyTags [Tag "jon RPC" (Just "Crudely improvised Garfield API") Nothing]
-- Doesn't work :(
-- & applyTagsFor (operationsOf $ toSwagger (Proxy :: Proxy SnackAPI)) [Tag "Snacks" Nothing Nothing]

View File

@ -1,10 +0,0 @@
{}:
let
pkgs = import ./nix/pkgs.nix {};
ghc = import ./nix/ghc924.nix pkgs;
haskellDeps = import ./nix/haskell-deps.nix;
in
pkgs.haskell.lib.buildStackProject {
name = "jon";
ghc = ghc.ghcWithPackages haskellDeps;
}

View File

@ -1,8 +0,0 @@
packages:
- .
resolver: ghc-9.2.4
system-ghc: true
nix:
enable: true
shell-file: stack-shell.nix
path: ["nixpkgs=./nix/pkgs.nix"]

View File

@ -1,14 +0,0 @@
<!DOCTYPE html>
<html>
<head>
<meta charset="UTF-8">
<link rel="stylesheet" href="./jon.css">
</head>
<body>
<!-- Compiled by Elm -->
<script src="./jon.js"></script>
<script>
Elm.Main.init();
</script>
</body>
</html>

View File

@ -1,31 +0,0 @@
html {
font-size: 16px;
}
button, input {
font-size: 0.8rem;
}
body {
font-family: Arial, Helvetica, sans-serif;
}
table {
border-collapse: collapse;
}
th, td {
padding: .2em .4em;
}
tr:not(:first-child):hover, tbody tr:hover {
background-color: lightblue;
}
@media print {
.noprint { display: none; }
body > div + div {
display: none !important;
}
}

View File

@ -1,2 +0,0 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"