I'm building a mini ERP, with some basic functionalities, I'm doing the Back End in Haskell. However, my code feels very imperative, so any tips and critiques will be highly appreciated.
Repo: https://github.com/werner/MadisonAPI
Example: https://github.com/werner/MadisonAPI/blob/master/src/Models/Warehouse.hs
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
module Models.Warehouse where
import GHC.Generics (Generic)
import Data.Maybe (fromMaybe)
import Data.Text as Text
import qualified Database.Esqueleto as E
import Data.Int (Int64)
import Data.Aeson (ToJSON, FromJSON)
import Web.HttpApiData (FromHttpApiData, ToHttpApiData, parseUrlPiece
, toUrlPiece, showTextData)
import Database.Persist.Postgresql (Entity (..), fromSqlKey)
import Database.Persist.Audit.Types
import Database.Persist.Audit.Class
import Models.Base
import Config
type RawWarehouseStock = (E.Value Int, E.Value String,
E.Value (Key User), E.Value (Maybe Double))
data WarehouseStock = WarehouseStock { wId :: Int
, wName :: String
, wUserId :: Int64
, wStock :: Double
}
deriving (Eq, Show, Read, Generic)
data CrudWarehouse = CrudWarehouse { cwName :: String } deriving (Eq, Show, Read, Generic)
instance ToJSON WarehouseStock
instance FromJSON WarehouseStock
instance ToJSON CrudWarehouse
instance FromJSON CrudWarehouse
data SortWarehouse = SWarehouseNameAsc
| SWarehouseNameDesc
| SWarehouseScopedIdAsc
| SWarehouseScopedIdDesc
deriving (Show, Read, Generic)
instance ToJSON SortWarehouse
instance FromJSON SortWarehouse
instance FromHttpApiData SortWarehouse where
parseUrlPiece sortWarehouse = Right (read $ Text.unpack sortWarehouse :: SortWarehouse)
instance ToHttpApiData SortWarehouse where
toUrlPiece = showTextData
data FilterWarehouse = FilterWarehouse { filterName :: Maybe String
, filterId :: Maybe Int }
deriving (Show, Read, Generic)
instance ToJSON FilterWarehouse
instance FromJSON FilterWarehouse
instance FromHttpApiData FilterWarehouse where
parseUrlPiece filterWarehouse = Right (read $ Text.unpack filterWarehouse :: FilterWarehouse)
instance ToHttpApiData FilterWarehouse where
toUrlPiece = showTextData
instance ToAudit Warehouse where
type AuditResult Warehouse = WarehouseAudit
toAudit v k auditAction editedBy editedOn = WarehouseAudit (warehouseName v) (warehouseUserId v)
(warehouseScopedId v)
k auditAction editedBy editedOn
getSortField :: E.SqlExpr (Entity Warehouse) -> SortWarehouse -> E.SqlExpr E.OrderBy
getSortField warehouses SWarehouseNameAsc = E.asc $ warehouses E.^. WarehouseName
getSortField warehouses SWarehouseNameDesc = E.desc $ warehouses E.^. WarehouseName
getSortField warehouses SWarehouseScopedIdAsc = E.asc $ warehouses E.^. WarehouseScopedId
getSortField warehouses SWarehouseScopedIdDesc = E.desc $ warehouses E.^. WarehouseScopedId
mapFilterWarehouse
:: E.Esqueleto query expr backend =>
expr (Entity Warehouse) -> FilterWarehouse -> query ()
mapFilterWarehouse warehouses (FilterWarehouse (Just name) Nothing) = E.where_ $ warehouses E.^. WarehouseName `E.ilike`
(E.%) E.++. E.val name E.++. (E.%)
mapFilterWarehouse warehouses (FilterWarehouse Nothing (Just id)) = E.where_ $ warehouses E.^. WarehouseScopedId E.==.
E.val id
mapFilterWarehouse warehouses (FilterWarehouse (Just name) (Just id)) = E.where_ $
(warehouses E.^. WarehouseName `E.ilike`
(E.%) E.++. E.val name E.++. (E.%))
E.&&.
warehouses E.^. WarehouseScopedId E.==. E.val id
mapFilterWarehouse warehouses (FilterWarehouse Nothing Nothing) = E.where_ $ warehouses E.^. WarehouseName `E.ilike`
(E.%) E.++. E.val "%" E.++. (E.%)
findAll' :: [SortWarehouse] -> Maybe Int64 -> Maybe Int64 -> FilterWarehouse -> App [RawWarehouseStock]
findAll' sortWarehouses limit offset filters = runDb
$ E.select
$ E.from $ \(warehouses `E.LeftOuterJoin` stocks) -> do
E.on $ E.just (warehouses E.^. WarehouseId) E.==. stocks E.?. StockWarehouseId
mapFilterWarehouse warehouses filters
E.orderBy $ Prelude.map (getSortField warehouses) sortWarehouses
E.groupBy (warehouses E.^. WarehouseId,
warehouses E.^. WarehouseName,
warehouses E.^. WarehouseUserId)
E.limit $ fromMaybe 10 limit
E.offset $ fromMaybe 0 offset
return
( warehouses E.^. WarehouseScopedId
, warehouses E.^. WarehouseName
, warehouses E.^. WarehouseUserId
, E.sum_ (stocks E.?. StockAmount)
)
transform' :: RawWarehouseStock -> WarehouseStock
transform' warehouse = WarehouseStock (E.unValue id)
(E.unValue name)
(fromSqlKey $ E.unValue userId)
(fromMaybe 0 $ E.unValue stock)
where (id, name, userId, stock) = warehouse
transformAll' :: [RawWarehouseStock] -> [WarehouseStock]
transformAll' = Prelude.map transform'
2ยบ Example: https://github.com/werner/MadisonAPI/blob/master/src/Api/Warehouse.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
module Api.Warehouse where
import Data.Monoid ((<>))
import GHC.Generics (Generic)
import Data.Maybe (fromMaybe)
import Data.Text as Text
import Data.Int (Int64)
import Database.Persist.Postgresql (insertBy, entityVal, updateWhere, deleteWhere,
PersistField(..),
Entity (..), fromSqlKey, insert, toSqlKey, update,
delete, selectFirst, selectList, (==.), (=.))
import qualified Database.Esqueleto as E
import Network.Wai (Application)
import Servant
import Web.HttpApiData (showTextData)
import Database.Persist.Audit.Queries
import Api.Types
import Config (App (..), Config (..))
import Models.Base
import Models.Warehouse
import Models.User
import qualified Api.Register as Register
type API =
"warehouses" :> MadisonAuthProtect
:> QueryParams "sortField" SortWarehouse
:> QueryParam "limit" Int64
:> QueryParam "offset" Int64
:> ReqBody '[JSON] FilterWarehouse :> Get '[JSON] [WarehouseStock]
:<|> "warehouses" :> MadisonAuthProtect
:> ReqBody '[JSON] CrudWarehouse :> Post '[JSON] Int
:<|> "warehouses" :> MadisonAuthProtect
:> Capture "id" Int
:> ReqBody '[JSON] CrudWarehouse :> Put '[JSON] Int
:<|> "warehouses" :> MadisonAuthProtect
:> Capture "id" Int :> Delete '[JSON] Int
server :: ServerT Api.Warehouse.API App
server = all' :<|> insert' :<|> update' :<|> delete'
all' :: MadisonAuthData -> [SortWarehouse] -> Maybe Int64 -> Maybe Int64 -> FilterWarehouse -> App [WarehouseStock]
all' session sortWarehouses limit offset filters = do
warehouses <- findAll' sortWarehouses limit offset filters
return $ transformAll' warehouses
insert' :: MadisonAuthData -> CrudWarehouse -> App Int
insert' showUser crudWarehouse = do
user <- runDb (selectFirst [SessionCookie ==. suId showUser] []) >>= getUserBySession
scopedId <- nextScopedId (fromSqlKey $ entityKey user) WarehouseUserId WarehouseScopedId
new <- runDb $ insertAndAuditBy ( Warehouse (cwName crudWarehouse) (entityKey user) scopedId )
( Text.pack $ userEmail $ entityVal user )
case new of
Left err -> throwError (err409 { errReasonPhrase = "Duplicate warehouse: "
<> (warehouseName $ entityVal err) })
Right key -> return scopedId
update' :: MadisonAuthData -> Int -> CrudWarehouse -> App Int
update' showUser id warehouse = do
user <- runDb (selectFirst [SessionCookie ==. suId showUser] []) >>= getUserBySession
runDb $ updateWhereAndAudit [WarehouseScopedId ==. id,
WarehouseUserId ==. entityKey user]
[WarehouseName =. cwName warehouse]
( Text.pack $ userEmail $ entityVal user )
return id
delete' :: MadisonAuthData -> Int -> App Int
delete' showUser id = do
user <- runDb (selectFirst [SessionCookie ==. suId showUser] []) >>= getUserBySession
runDb $ deleteWhereAndAudit [WarehouseScopedId ==. id, WarehouseUserId ==. entityKey user]
( Text.pack $ userEmail $ entityVal user )
return id
Nothing (Just id)
case of mapFilterWarehouse?) – Gurkenglas Jan 20 at 13:33