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-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-05-09 14:53:19 +00:00
|
|
|
head <$> (liftIO $ runInsert_ conn (insertUser us (utctDay now) randSalt))
|
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
|
2019-07-18 14:58:22 +00:00
|
|
|
{ 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
|
2019-07-18 14:58:22 +00:00
|
|
|
{ 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 ()
|
2019-07-18 14:58:22 +00:00
|
|
|
use359c65b0e68b6607a03d39f908ca26827ab97fb6e21096rPostUpdate Nothing _ _ =
|
2019-05-16 16:37:04 +00:00
|
|
|
throwError $ err403
|
2019-07-18 14:58:22 +00:00
|
|
|
{ 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
|
|
|
|
void $ liftIO $ runUpdate_ conn (updateUserDetails id uds (utctDay now))
|
|
|
|
else
|
2019-07-18 14:10:18 +00:00
|
|
|
throwError $ err403
|
2019-07-18 14:58:22 +00:00
|
|
|
{ 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-07-18 12:57:35 +00:00
|
|
|
list :<|>
|
2019-07-18 14:58:22 +00:00
|
|
|
new :<|>
|
|
|
|
update
|
2019-07-18 12:57:35 +00:00
|
|
|
where
|
2019-07-18 15:09:26 +00:00
|
|
|
list :: MateHandler [Product]
|
2019-07-18 12:57:35 +00:00
|
|
|
list = do
|
|
|
|
conn <- rsConnection <$> ask
|
2019-07-18 15:09:26 +00:00
|
|
|
productSelect conn
|
2019-07-18 12:57:35 +00:00
|
|
|
|
2019-07-18 15:09:26 +00:00
|
|
|
new :: Maybe Int -> ProductSubmit -> MateHandler Int
|
2019-07-18 14:58:22 +00:00
|
|
|
new (Just _) bevsub = do
|
2019-07-18 12:57:35 +00:00
|
|
|
conn <- rsConnection <$> ask
|
2019-07-18 15:09:26 +00:00
|
|
|
head <$> (liftIO $ runInsert_ conn (insertProduct bevsub))
|
2019-07-18 14:58:22 +00:00
|
|
|
new Nothing _ =
|
|
|
|
throwError $ err403
|
|
|
|
|
2019-07-18 15:09:26 +00:00
|
|
|
update :: Maybe Int -> Int -> ProductSubmit -> MateHandler ()
|
2019-07-18 14:58:22 +00:00
|
|
|
update (Just _) bid bevsub = do
|
|
|
|
conn <- rsConnection <$> ask
|
2019-07-18 15:09:26 +00:00
|
|
|
void $ liftIO $ runUpdate_ conn (updateProduct bid bevsub)
|
2019-07-18 14:58:22 +00:00
|
|
|
update Nothing _ _ =
|
|
|
|
throwError $ err403
|
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
|
|
|
|
mmiss <- checkProductAvailability conn pd
|
|
|
|
case mmiss of
|
|
|
|
Just miss -> return
|
|
|
|
( (pd {pdAmount = miss}):ms
|
|
|
|
, (pd {pdAmount = max 0 (pdAmount pd - miss)}:rs)
|
|
|
|
)
|
|
|
|
Nothing -> return
|
|
|
|
( ms
|
|
|
|
, pd:rs
|
|
|
|
)
|
|
|
|
)
|
|
|
|
([], [])
|
|
|
|
pds
|
|
|
|
void$ liftIO $ mapM_ (\pd -> runUpdate_ conn (reduceProductAmount pd)) real
|
|
|
|
price <- foldM (\total pd -> fmap (+ total) (getProductPrice pd conn)) 0 real
|
|
|
|
liftIO $ runUpdate_ conn (addToUserBalance auid (-price))
|
|
|
|
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 conn pd
|
|
|
|
case mmiss of
|
|
|
|
Just miss -> return
|
|
|
|
( (pd {pdAmount = miss}):ms
|
|
|
|
, (pd {pdAmount = max 0 (pdAmount pd - miss)}:rs)
|
|
|
|
)
|
|
|
|
Nothing -> return
|
|
|
|
( ms
|
|
|
|
, pd:rs
|
|
|
|
)
|
|
|
|
)
|
|
|
|
([], [])
|
|
|
|
pds
|
|
|
|
void $ liftIO $ mapM_ (\pd -> runUpdate_ conn (reduceProductAmount pd)) real
|
|
|
|
price <- foldM (\total pd -> fmap (+ total) (getProductPrice pd conn)) 0 real
|
|
|
|
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"
|
|
|
|
}
|