From 7f3dfc9c296088276a21e12540155e1b3dc7fc7f Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 15 Apr 2019 22:23:25 +0200 Subject: [PATCH] =?UTF-8?q?w=C3=B6rk=20w=C3=B6rk?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .gitignore | 3 +- mateamt.cabal | 16 +++++- shell.nix | 35 ++++++++++++ src/API.hs | 29 ++++++++++ src/Main.hs | 45 ++++++++++++++- src/Model.hs | 6 ++ src/Model/Beverage.hs | 77 +++++++++++++++++++++++++ src/Model/User.hs | 129 ++++++++++++++++++++++++++++++++++++++++++ src/Types.hs | 20 +++++++ 9 files changed, 357 insertions(+), 3 deletions(-) create mode 100644 shell.nix create mode 100644 src/API.hs create mode 100644 src/Model.hs create mode 100644 src/Model/Beverage.hs create mode 100644 src/Model/User.hs create mode 100644 src/Types.hs diff --git a/.gitignore b/.gitignore index 7b85fa5..223c20b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ *.swp -dist-newstile/ +dist-newstyle/ *.hp *.ps *.pdf *.prof +.ghc* diff --git a/mateamt.cabal b/mateamt.cabal index 60df032..71c76e7 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -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 diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..f2c9686 --- /dev/null +++ b/shell.nix @@ -0,0 +1,35 @@ +{ nixpkgs ? import {}, 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 diff --git a/src/API.hs b/src/API.hs new file mode 100644 index 0000000..3f5ebbd --- /dev/null +++ b/src/API.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index 65ae4a0..3ec28d2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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)) diff --git a/src/Model.hs b/src/Model.hs new file mode 100644 index 0000000..5b24a24 --- /dev/null +++ b/src/Model.hs @@ -0,0 +1,6 @@ +module Model + ( module M + ) where + +import Model.User as M +import Model.Beverage as M diff --git a/src/Model/Beverage.hs b/src/Model/Beverage.hs new file mode 100644 index 0000000..f2443ca --- /dev/null +++ b/src/Model/Beverage.hs @@ -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" + ) + ) diff --git a/src/Model/User.hs b/src/Model/User.hs new file mode 100644 index 0000000..358174f --- /dev/null +++ b/src/Model/User.hs @@ -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 +} diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 0000000..6560789 --- /dev/null +++ b/src/Types.hs @@ -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)