mateamt/src/Main.hs

292 lines
7 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where
import Servant
import Servant.Server.Experimental.Auth
import Data.Time.Clock
import Data.ByteString.Random
import Data.ByteString.Base16 (decode)
import Data.Set (empty)
import Data.Maybe (isJust)
import Database.PostgreSQL.Simple
import Network.Wai
import Network.Wai.Logger
import Network.Wai.Handler.Warp
import Opaleye hiding (max)
import Control.Monad.IO.Class (liftIO)
import Control.Monad (void)
import Control.Monad.Reader
import Control.Concurrent.STM.TVar
-- internal imports
import API
import Model as M
import Types
main :: IO ()
main = do
conn <- connectPostgreSQL
"host='localhost' port=5432 dbname='mateamt' user='mateamt' password='mateamt'"
store <- newTVarIO empty
execute_ conn initUser
execute_ conn initProduct
execute_ conn initToken
execute_ conn initAmount
execute_ conn initJournal
withStdoutLogger $ \log -> do
let settings = setPort 3000 $ setLogger log defaultSettings
initState = ReadState
{ rsConnection = conn
, rsTicketStore = store
}
runSettings settings (app initState)
app :: ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
app initState =
serveWithContext userApi (genAuthServerContext (rsConnection initState)) $
hoistServerWithContext
userApi
authProxy
(`runReaderT` initState)
( authGet :<|>
authSend :<|>
authLogout :<|>
userNew :<|>
userGet :<|>
userUpdate :<|>
userList :<|>
productNew :<|>
productOverview :<|>
productStockRefill :<|>
productStockUpdate :<|>
productList :<|>
buy
)
userApi :: Proxy UserAPI
userApi = Proxy
authProxy :: Proxy '[ AuthHandler Request (Maybe Int) ]
authProxy = Proxy
genAuthServerContext
:: Connection
-> Context '[ AuthHandler Request (Maybe Int) ]
genAuthServerContext conn = authHandler conn Servant.:. EmptyContext
type instance AuthServerData (AuthProtect "header-auth") = Maybe Int
authHandler :: Connection -> AuthHandler Request (Maybe Int)
authHandler conn = mkAuthHandler handler
where
handler :: Request -> Handler (Maybe Int)
handler req = do
let headers = requestHeaders req
res <- case lookup "Authentication" headers of
Just hh ->
validateToken conn (fst $ decode hh)
_ ->
return Nothing
return res
authGet :: Int -> MateHandler AuthInfo
authGet id =
getUserAuthInfo id
authSend :: AuthRequest -> MateHandler AuthResult
authSend = processAuthRequest
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"
}
userNew :: UserSubmit -> MateHandler Int
userNew us = do
now <- liftIO $ getCurrentTime
randSalt <- liftIO $ random 8
conn <- rsConnection <$> ask
insertUser us (utctDay now) randSalt conn
userGet :: Maybe Int -> Int -> MateHandler UserDetails
userGet Nothing _ =
throwError $ err403
{ errBody = "No Authentication present"
}
userGet (Just aid) id =
if aid == id
then do
now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask
-- void $ liftIO $ runUpdate_ conn (updateUser id us (utctDay now))
userDetailsSelect conn id
else
throwError $ err403
{ errBody = "Wrong Authentication present"
}
userUpdate :: Maybe Int -> Int -> UserDetailsSubmit -> MateHandler ()
userUpdate Nothing _ _ =
throwError $ err403
{ errBody = "No Authentication present"
}
userUpdate (Just aid) id uds =
if aid == id
then do
now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask
void $ updateUserDetails id uds (utctDay now) conn
else
throwError $ err403
{ errBody = "Wrong Authentication present"
}
userList :: Maybe Int -> Maybe Refine -> MateHandler [User]
userList muid ref = do
conn <- rsConnection <$> ask
userSelect conn ref
productNew :: Maybe Int -> ProductSubmit -> MateHandler Int
productNew (Just _) bevsub = do
conn <- rsConnection <$> ask
now <- liftIO $ getCurrentTime
bevid <- insertProduct bevsub conn
void $ insertNewEmptyAmount bevid now bevsub conn
return bevid
productNew Nothing _ =
throwError $ err403
productOverview :: Int -> MateHandler ProductOverview
productOverview pid = do
conn <- rsConnection <$> ask
productOverviewSelectSingle pid conn
productStockRefill :: Maybe Int -> [AmountRefill] -> MateHandler ()
productStockRefill (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"
}
productStockRefill Nothing _ =
throwError $ err403
{ errBody = "No Authentication present"
}
productStockUpdate :: Maybe Int -> [AmountUpdate] -> MateHandler ()
productStockUpdate (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"
}
productStockUpdate Nothing _ =
throwError $ err403
{ errBody = "No Authentication present"
}
productList :: MateHandler [ProductOverview]
productList = do
conn <- rsConnection <$> ask
productOverviewSelect conn
buy (Just auid) pds = do
conn <- rsConnection <$> ask
(missing, real) <- foldM (\acc@(ms, rs) pd -> do
mmiss <- checkProductAvailability pd conn
case mmiss of
Just miss -> return
( (pd {purchaseDetailAmount = miss}):ms
, (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
)
Nothing -> return
( ms
, pd:rs
)
)
([], [])
pds
void $ mapM_ (\pd -> postBuyProductAmountUpdate pd conn) real
price <- foldM
(\total pd ->
fmap (+ total) (getLatestTotalPrice pd conn)
)
0
real
addToUserBalance auid (-price) conn
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
mmiss <- checkProductAvailability pd conn
case mmiss of
Just miss -> return
( (pd {purchaseDetailAmount = miss}):ms
, (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
)
Nothing -> return
( ms
, pd:rs
)
)
([], [])
pds
void $ mapM_
(\pd -> postBuyProductAmountUpdate pd conn)
real
price <- foldM
(\total pd ->
fmap (+ total) (getLatestTotalPrice pd conn)
)
0
real
return $ PurchaseResult
(PayAmount price)
missing