wörk wörk

.gitignore

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

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

shell.nix

@@ -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

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

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

src/Model.hs

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

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

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
+}

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)