mateamt/src/Main.hs

289 lines
7.3 KiB
Haskell
Raw Normal View History

2019-04-15 20:23:25 +00:00
{-# LANGUAGE OverloadedStrings #-}
2019-04-17 05:51:15 +00:00
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
2019-05-13 20:50:24 +00:00
{-# LANGUAGE FlexibleContexts #-}
2019-03-22 21:34:01 +00:00
module Main where
2019-04-15 20:23:25 +00:00
import Servant
2019-04-17 05:51:15 +00:00
import Servant.Server.Experimental.Auth
2019-04-15 20:23:25 +00:00
import Data.Time.Clock
2019-04-21 15:27:15 +00:00
import Data.ByteString.Random
2019-05-16 16:36:39 +00:00
import Data.ByteString.Base16 (decode)
2019-04-21 15:27:15 +00:00
2019-05-06 21:41:05 +00:00
import Data.Set (empty)
2019-05-13 20:50:24 +00:00
import Data.Maybe (isJust)
2019-04-15 20:23:25 +00:00
import Database.PostgreSQL.Simple
2019-04-16 11:30:16 +00:00
import Network.Wai
import Network.Wai.Logger
2019-04-15 20:23:25 +00:00
import Network.Wai.Handler.Warp
2019-07-20 16:36:47 +00:00
import Opaleye hiding (max)
2019-04-15 20:23:25 +00:00
import Control.Monad.IO.Class (liftIO)
import Control.Monad (void)
2019-05-08 23:24:58 +00:00
import Control.Monad.Reader
2019-05-06 21:41:05 +00:00
import Control.Concurrent.STM.TVar
2019-04-15 20:23:25 +00:00
-- internal imports
import API
import Model as M
import Types
2019-03-22 21:34:01 +00:00
main :: IO ()
2019-04-15 20:23:25 +00:00
main = do
conn <- connectPostgreSQL
"host='localhost' port=5432 dbname='mateamt' user='mateamt' password='mateamt'"
2019-05-06 21:41:05 +00:00
store <- newTVarIO empty
2019-04-16 11:03:07 +00:00
execute_ conn initUser
2019-07-18 15:09:26 +00:00
execute_ conn initProduct
2019-04-21 15:27:15 +00:00
execute_ conn initToken
2019-07-21 14:39:41 +00:00
execute_ conn initAmount
2019-04-16 11:30:16 +00:00
withStdoutLogger $ \log -> do
let settings = setPort 3000 $ setLogger log defaultSettings
2019-05-06 21:41:05 +00:00
initState = ReadState
{ rsConnection = conn
, rsTicketStore = store
}
runSettings settings (app initState)
2019-04-15 20:23:25 +00:00
2019-05-06 21:41:05 +00:00
app :: ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
2019-05-13 20:50:24 +00:00
app initState =
serveWithContext userApi (genAuthServerContext (rsConnection initState)) $
hoistServerWithContext
userApi
authProxy
(`runReaderT` initState)
( users :<|>
2019-07-18 15:09:26 +00:00
products :<|>
2019-07-18 17:01:49 +00:00
buy :<|>
2019-05-13 20:50:24 +00:00
auth
)
2019-04-15 20:23:25 +00:00
userApi :: Proxy UserAPI
userApi = Proxy
2019-05-13 20:50:24 +00:00
authProxy :: Proxy '[ AuthHandler Request (Maybe Int) ]
2019-05-09 14:53:19 +00:00
authProxy = Proxy
2019-05-13 20:50:24 +00:00
genAuthServerContext
:: Connection
-> Context '[ AuthHandler Request (Maybe Int) ]
genAuthServerContext conn = authHandler conn Servant.:. EmptyContext
2019-04-17 05:51:15 +00:00
2019-05-13 20:50:24 +00:00
type instance AuthServerData (AuthProtect "header-auth") = Maybe Int
2019-04-17 05:51:15 +00:00
2019-05-13 20:50:24 +00:00
authHandler :: Connection -> AuthHandler Request (Maybe Int)
authHandler conn = mkAuthHandler handler
2019-04-17 05:51:15 +00:00
where
2019-05-13 20:50:24 +00:00
handler :: Request -> Handler (Maybe Int)
2019-04-17 05:51:15 +00:00
handler req = do
let headers = requestHeaders req
2019-07-18 14:08:38 +00:00
res <- case lookup "Authentication" headers of
Just hh ->
2019-05-16 16:36:39 +00:00
validateToken conn (fst $ decode hh)
2019-05-13 20:50:24 +00:00
_ ->
return Nothing
2019-04-17 05:51:15 +00:00
return res
2019-05-08 23:24:58 +00:00
users =
2019-05-13 20:50:24 +00:00
userList :<|>
userNew :<|>
2019-05-16 16:37:04 +00:00
userGetUpdate :<|>
userPostUpdate
2019-04-15 20:23:25 +00:00
where
2019-05-16 02:07:20 +00:00
userList :: Maybe Int -> Maybe Refine -> MateHandler [User]
userList muid ref = do
2019-05-08 23:24:58 +00:00
conn <- rsConnection <$> ask
2019-07-18 12:57:35 +00:00
userSelect conn ref
2019-04-17 08:45:48 +00:00
2019-05-08 23:24:58 +00:00
userNew :: UserSubmit -> MateHandler Int
2019-05-10 12:10:11 +00:00
userNew us = do
2019-05-09 14:53:19 +00:00
now <- liftIO $ getCurrentTime
randSalt <- liftIO $ random 8
2019-05-08 23:24:58 +00:00
conn <- rsConnection <$> ask
2019-07-28 09:55:22 +00:00
insertUser us (utctDay now) randSalt conn
2019-04-17 08:45:48 +00:00
2019-05-16 16:37:04 +00:00
userGetUpdate :: Maybe Int -> Int -> MateHandler UserDetails
userGetUpdate Nothing _ =
2019-05-16 02:07:20 +00:00
throwError $ err403
{ errBody = "No Authentication present"
2019-05-16 02:07:20 +00:00
}
2019-05-16 16:37:04 +00:00
userGetUpdate (Just aid) id =
if aid == id
2019-05-16 02:07:20 +00:00
then do
now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask
2019-05-16 16:37:04 +00:00
-- void $ liftIO $ runUpdate_ conn (updateUser id us (utctDay now))
userDetailsSelect conn id
2019-05-16 02:07:20 +00:00
else
2019-07-18 14:10:18 +00:00
throwError $ err403
{ errBody = "Wrong Authentication present"
2019-07-18 14:10:18 +00:00
}
2019-05-16 16:37:04 +00:00
userPostUpdate :: Maybe Int -> Int -> UserDetailsSubmit -> MateHandler ()
use359c65b0e68b6607a03d39f908ca26827ab97fb6e21096rPostUpdate Nothing _ _ =
2019-05-16 16:37:04 +00:00
throwError $ err403
{ errBody = "No Authentication present"
2019-05-16 16:37:04 +00:00
}
userPostUpdate (Just aid) id uds =
if aid == id
then do
now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask
2019-07-28 09:55:22 +00:00
void $ updateUserDetails id uds (utctDay now) conn
2019-05-16 16:37:04 +00:00
else
2019-07-18 14:10:18 +00:00
throwError $ err403
{ errBody = "Wrong Authentication present"
2019-07-18 14:10:18 +00:00
}
2019-04-17 08:45:48 +00:00
2019-07-18 15:09:26 +00:00
products =
2019-08-03 07:30:18 +00:00
listLong :<|>
new :<|>
stockUpdate :<|>
stockRefill
2019-07-18 12:57:35 +00:00
where
listLong :: MateHandler [ProductOverview]
listLong = do
2019-07-18 12:57:35 +00:00
conn <- rsConnection <$> ask
2019-07-28 09:55:22 +00:00
productOverviewSelect conn
2019-07-18 12:57:35 +00:00
2019-07-18 15:09:26 +00:00
new :: Maybe Int -> ProductSubmit -> MateHandler Int
new (Just _) bevsub = do
2019-07-18 12:57:35 +00:00
conn <- rsConnection <$> ask
2019-07-27 14:34:28 +00:00
now <- liftIO $ getCurrentTime
2019-07-28 09:55:22 +00:00
bevid <- insertProduct bevsub conn
void $ insertNewEmptyAmount bevid now bevsub conn
2019-07-27 14:34:28 +00:00
return bevid
new Nothing _ =
throwError $ err403
stockUpdate :: Maybe Int -> [AmountUpdate] -> MateHandler ()
stockUpdate (Just _) amoups = do
if all ((>= 0) . amountUpdateRealAmount) amoups
then do
conn <- rsConnection <$> ask
void $ manualProductAmountUpdate amoups conn
else
throwError $ err406
{ errBody = "Amounts less than 0 are not acceptable"
}
stockUpdate Nothing _ =
throwError $ err403
{ errBody = "No Authentication present"
}
stockRefill :: Maybe Int -> [AmountRefill] -> MateHandler ()
stockRefill (Just _) amorefs = do
if all ((>= 0) . amountRefillAmount) amorefs
then do
conn <- rsConnection <$> ask
void $ manualProductAmountRefill amorefs conn
else
throwError $ err406
{ errBody = "Amounts less than 0 are not acceptable"
}
stockRefill Nothing _ =
throwError $ err403
{ errBody = "No Authentication present"
}
2019-07-18 12:57:35 +00:00
2019-07-20 16:36:47 +00:00
buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult
2019-07-18 17:01:49 +00:00
buy (Just auid) pds = do
conn <- rsConnection <$> ask
2019-07-20 16:36:47 +00:00
(missing, real) <- foldM (\acc@(ms, rs) pd -> do
2019-07-27 14:34:28 +00:00
mmiss <- checkProductAvailability pd conn
2019-07-20 16:36:47 +00:00
case mmiss of
Just miss -> return
2019-07-28 09:55:22 +00:00
( (pd {purchaseDetailAmount = miss}):ms
, (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
2019-07-20 16:36:47 +00:00
)
Nothing -> return
( ms
, pd:rs
)
)
([], [])
pds
2019-07-27 14:34:28 +00:00
void $ mapM_ (\pd -> postBuyProductAmountUpdate pd conn) real
price <- foldM
(\total pd ->
fmap (+ total) (getLatestTotalPrice pd conn)
)
0
real
2019-07-28 09:55:22 +00:00
addToUserBalance auid (-price) conn
2019-07-20 16:36:47 +00:00
newBalance <- userBalanceSelect conn auid
return $ PurchaseResult
( if newBalance < 0
then PurchaseDebtful
else PurchaseOK
)
missing
buy Nothing pds = do
conn <- rsConnection <$> ask
(missing, real) <- foldM (\acc@(ms, rs) pd -> do
2019-07-27 14:34:28 +00:00
mmiss <- checkProductAvailability pd conn
2019-07-20 16:36:47 +00:00
case mmiss of
Just miss -> return
2019-07-28 09:55:22 +00:00
( (pd {purchaseDetailAmount = miss}):ms
, (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
2019-07-20 16:36:47 +00:00
)
Nothing -> return
( ms
, pd:rs
)
)
([], [])
pds
2019-07-27 14:34:28 +00:00
void $ mapM_
(\pd -> postBuyProductAmountUpdate pd conn)
real
price <- foldM
(\total pd ->
fmap (+ total) (getLatestTotalPrice pd conn)
)
0
real
2019-07-20 16:36:47 +00:00
return $ PurchaseResult
(PayAmount price)
missing
2019-07-18 17:01:49 +00:00
2019-05-13 20:50:24 +00:00
auth =
authGet :<|>
2019-07-18 14:09:59 +00:00
authSend :<|>
authLogout
2019-05-13 20:50:24 +00:00
where
2019-05-08 23:24:58 +00:00
authGet :: Int -> MateHandler AuthInfo
authGet id =
getUserAuthInfo id
2019-04-17 08:45:48 +00:00
2019-05-08 23:24:58 +00:00
authSend :: AuthRequest -> MateHandler AuthResult
2019-05-10 12:10:11 +00:00
authSend = processAuthRequest
2019-07-18 14:09:59 +00:00
authLogout :: Maybe Int -> Int -> MateHandler ()
authLogout (Just muid) luid = do
if muid == luid
then
processLogout luid
else
throwError $ err403
{ errBody = "Forbidden"
}
authLogout Nothing _ = do
throwError $ err403
{ errBody = "Forbidden"
}