Remove Haskell code
This commit is contained in:
parent
3ad649a402
commit
b729e91aaa
7
LICENSE
7
LICENSE
@ -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.
|
||||
2
Makefile
2
Makefile
@ -1,2 +0,0 @@
|
||||
static/jon.js: elm/*.elm $(wildcard elm/**/*.elm)
|
||||
elm make --debug --output static/jon.js elm/Main.elm
|
||||
@ -1,3 +0,0 @@
|
||||
module Main (main) where
|
||||
|
||||
import Jon.Main (main)
|
||||
21
default.nix
21
default.nix
@ -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;
|
||||
}
|
||||
28
elm.json
28
elm.json
@ -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": {}
|
||||
}
|
||||
}
|
||||
425
elm/Main.elm
425
elm/Main.elm
@ -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
103
jon.cabal
@ -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
|
||||
@ -1,2 +0,0 @@
|
||||
pkgs:
|
||||
pkgs.haskell.packages.ghc924
|
||||
@ -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
|
||||
]
|
||||
@ -1,5 +0,0 @@
|
||||
{ overlays ? [] }:
|
||||
let
|
||||
sources = import ./sources.nix;
|
||||
in
|
||||
import sources.nixpkgs { inherit overlays; }
|
||||
@ -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"
|
||||
}
|
||||
}
|
||||
194
nix/sources.nix
194
nix/sources.nix
@ -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); }
|
||||
71
package.yaml
71
package.yaml
@ -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
|
||||
@ -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 ()
|
||||
@ -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)
|
||||
@ -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
|
||||
@ -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]
|
||||
@ -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;
|
||||
}
|
||||
@ -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"]
|
||||
@ -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>
|
||||
@ -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;
|
||||
}
|
||||
}
|
||||
@ -1,2 +0,0 @@
|
||||
main :: IO ()
|
||||
main = putStrLn "Test suite not yet implemented"
|
||||
Loading…
x
Reference in New Issue
Block a user