wörk wörk

This commit is contained in:
nek0 2019-04-15 22:23:25 +02:00
parent 240b6248e6
commit 7f3dfc9c29
9 changed files with 357 additions and 3 deletions

3
.gitignore vendored
View file

@ -1,6 +1,7 @@
*.swp
dist-newstile/
dist-newstyle/
*.hp
*.ps
*.pdf
*.prof
.ghc*

View file

@ -17,8 +17,22 @@ extra-source-files: CHANGELOG.md
executable mateamt
main-is: Main.hs
-- other-modules:
other-modules: API
, Model
, Model.User
, Model.Beverage
, Types
-- other-extensions:
build-depends: base ^>=4.12.0.0
, servant
, servant-server
, opaleye
, aeson
, text
, time
, product-profunctors
, postgresql-simple
, warp
, http-api-data
hs-source-dirs: src
default-language: Haskell2010

35
shell.nix Normal file
View file

@ -0,0 +1,35 @@
{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
let
inherit (nixpkgs) pkgs;
f = { mkDerivation, aeson, base, opaleye, postgresql-simple
, product-profunctors, servant, servant-server, stdenv, text, time
, warp
}:
mkDerivation {
pname = "mateamt";
version = "0.0.0.0";
src = ./.;
isLibrary = false;
isExecutable = true;
executableHaskellDepends = [
aeson base opaleye postgresql-simple product-profunctors servant
servant-server text time warp
];
description = "A whole new matemat";
license = stdenv.lib.licenses.agpl3;
};
haskellPackages = if compiler == "default"
then pkgs.haskellPackages
else pkgs.haskell.packages.${compiler};
variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
drv = variant (haskellPackages.callPackage f {});
in
if pkgs.lib.inNixShell then drv.env else drv

29
src/API.hs Normal file
View file

@ -0,0 +1,29 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module API where
import Data.Text
import Data.Time (UTCTime)
import Servant.API
-- internal imports
import Model as M
import Types
type UserAPI = "user" :>
( "list" :> QueryParam "refine" Refine :> Get '[JSON] [User]
:<|> "new" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int
)
data SortBy = Name

View file

@ -1,4 +1,47 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Servant
import Data.Time.Clock
import Database.PostgreSQL.Simple
import Network.Wai.Handler.Warp
import Opaleye
import Control.Monad.IO.Class (liftIO)
import Control.Monad (void)
-- internal imports
import API
import Model as M
import Types
main :: IO ()
main = putStrLn "Hello, Haskell!"
main = do
conn <- connectPostgreSQL
"host='localhost' port=5432 dbname='mateamt' user='mateamt' password='mateamt'"
run 3000 (app conn)
app :: Connection -> Application
app conn = serve userApi (users conn)
userApi :: Proxy UserAPI
userApi = Proxy
users :: Connection -> Server UserAPI
users conn =
userList :<|>
userNew
where
userList :: Maybe Refine -> Handler [User]
userList ref = liftIO $ userSelect conn ref
userNew :: UserSubmit -> Handler Int
userNew us = liftIO $ do
now <- getCurrentTime
head <$> runInsert_ conn (insertUser us (utctDay now))

6
src/Model.hs Normal file
View file

@ -0,0 +1,6 @@
module Model
( module M
) where
import Model.User as M
import Model.Beverage as M

77
src/Model/Beverage.hs Normal file
View file

@ -0,0 +1,77 @@
{-# LANGUAGE DeriveGeneric #-}
module Model.Beverage where
import Data.Text as T
import Data.Time.Calendar (Day)
import Data.Profunctor.Product (p12)
import Data.Aeson
import Data.Aeson.Types
import GHC.Generics
import Opaleye as O
data Beverage = Beverage
{ beverageIdent :: T.Text
, beveragePrice :: Int
, beverageAmount :: Int
, beverageVanish :: Int
, beverageMl :: Int
, beverageAvatar :: Maybe Word
, beverageSupplier :: Maybe Word
, beverageMaxAmount :: Int
, beverageTotalBought :: Int
, beverageAmonutPerCrate :: Int
, beveragePricePerCrate :: Maybe Int
, beverageArtNr :: Maybe T.Text
} deriving (Generic, Show)
instance ToJSON Beverage where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Beverage
beverageTable :: Table
( Field SqlText
, Field SqlInt8
, Field SqlInt8
, Field SqlInt8
, Field SqlInt8
, FieldNullable SqlInt4
, FieldNullable SqlInt4
, Field SqlInt8
, Field SqlInt8
, Field SqlInt8
, FieldNullable SqlInt8
, FieldNullable SqlText
)
( Field SqlText
, Field SqlInt8
, Field SqlInt8
, Field SqlInt8
, Field SqlInt8
, FieldNullable SqlInt4
, FieldNullable SqlInt4
, Field SqlInt8
, Field SqlInt8
, Field SqlInt8
, FieldNullable SqlInt8
, FieldNullable SqlText
)
beverageTable = table "beverage" (
p12
( tableField "ident"
, tableField "price"
, tableField "amount"
, tableField "vanish"
, tableField "ml"
, tableField "avatar"
, tableField "supplier"
, tableField "max_amount"
, tableField "total_bought"
, tableField "amount_per_crate"
, tableField "price_per_crate"
, tableField "art_nr"
)
)

129
src/Model/User.hs Normal file
View file

@ -0,0 +1,129 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Model.User where
import Data.Text as T
import Data.Time.Calendar
import Data.Time.Clock
import Data.Profunctor.Product (p7)
import Data.Aeson
import Data.Int (Int64)
import Data.Maybe (fromJust)
import qualified Database.PostgreSQL.Simple as PGS
import GHC.Generics
import Control.Arrow ((<<<))
import Opaleye as O
import qualified Opaleye.Constant as C
-- internal imports
import Types
data User = User
{ userId :: Int
, userIdent :: T.Text
, userBalance :: Int
, userTimeStamp :: Day
, userEmail :: Maybe T.Text
, userAvatar :: Maybe Int
, userPin :: Maybe T.Text
}
deriving (Generic, Show)
instance ToJSON User where
toEncoding = genericToEncoding defaultOptions
instance FromJSON User
data UserSubmit = UserSubmit
{ userSubmitIdent :: T.Text
, userSubmitEmail :: Maybe T.Text
, userSubmitPin :: Maybe T.Text
}
deriving (Generic, Show)
instance ToJSON UserSubmit where
toEncoding = genericToEncoding defaultOptions
instance FromJSON UserSubmit
userTable :: Table
( Maybe (Field SqlInt4)
, Field SqlText
, Field SqlInt4
, Field SqlDate
, FieldNullable SqlText
, FieldNullable SqlInt4
, FieldNullable SqlText
)
( Field SqlInt4
, Field SqlText
, Field SqlInt4
, Field SqlDate
, FieldNullable SqlText
, FieldNullable SqlInt4
, FieldNullable SqlText
)
userTable = table "user" (
p7
( tableField "id"
, tableField "ident"
, tableField "balance"
, tableField "time_stamp"
, tableField "email"
, tableField "avatar"
, tableField "pin"
)
)
userSelect
:: PGS.Connection
-> Maybe Refine
-> IO [User]
userSelect conn ref = do
today <- utctDay <$> getCurrentTime
(mapM
(\(i1, i2, i3, i4, i5, i6, i7) -> return $
User
i1
i2
i3
i4
i5
i6
i7
)
) =<< runSelect conn (case ref of
Nothing -> keepWhen (\(_, _, _, ts, _, _, _) ->
ts .>= C.constant (addDays (-30) today)
) <<< queryTable userTable
Just All -> selectTable userTable
Just Old -> keepWhen (\(_, _, _, ts, _, _, _) ->
ts .<= C.constant (addDays (-30) today)
) <<< queryTable userTable
)
insertUser :: UserSubmit -> Day -> Insert [Int]
insertUser us now = Insert
{ iTable = userTable
, iRows =
[
( C.constant (Nothing :: Maybe Int)
, C.constant (userSubmitIdent us)
, C.constant (0 :: Int)
, C.constant now
, C.constant (userSubmitEmail us)
, C.constant (Nothing :: Maybe Int)
, C.constant (userSubmitPin us)
)
]
, iReturning = rReturning (\(id, _, _, _, _, _, _) -> id)
, iOnConflict = Nothing
}

20
src/Types.hs Normal file
View file

@ -0,0 +1,20 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Types where
import Data.Text
import GHC.Generics
import Web.HttpApiData
data Refine = All | Old
deriving (Generic, Show, Enum)
instance FromHttpApiData Refine where
parseQueryParam t =
case t of
"all" -> Right All
"old" -> Right Old
x -> Left ("Error: Unknown refine " <> x)