mateamt/app/Main.hs

112 lines
2.6 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
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-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-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-08-10 08:37:45 +00:00
import Control
2019-04-15 20:23:25 +00:00
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-09-07 18:05:24 +00:00
void $ execute_ conn initAvatar
2019-09-07 00:48:05 +00:00
void $ execute_ conn initUser
void $ execute_ conn initProduct
void $ execute_ conn initToken
void $ execute_ conn initAmount
void $ execute_ conn initJournal
withStdoutLogger $ \ilog -> do
2019-09-09 10:51:11 +00:00
let settings = setPort 8000 $ setLogger ilog 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 =
2019-09-09 10:52:30 +00:00
serveWithContext mateApi (genAuthServerContext (rsConnection initState)) $
2019-05-13 20:50:24 +00:00
hoistServerWithContext
2019-09-09 10:52:30 +00:00
mateApi
2019-05-13 20:50:24 +00:00
authProxy
(`runReaderT` initState)
2019-08-06 18:15:54 +00:00
( authGet :<|>
authSend :<|>
authLogout :<|>
userNew :<|>
userGet :<|>
userUpdate :<|>
userList :<|>
2019-08-14 16:03:51 +00:00
userRecharge :<|>
2019-09-06 19:43:46 +00:00
userTransfer :<|>
2019-08-06 18:15:54 +00:00
productNew :<|>
productOverview :<|>
productStockRefill :<|>
productStockUpdate :<|>
productList :<|>
2019-08-10 08:36:20 +00:00
buy :<|>
2019-09-07 18:05:24 +00:00
journalShow :<|>
avatarGet :<|>
avatarInsert :<|>
avatarUpdate :<|>
avatarList
2019-05-13 20:50:24 +00:00
)
2019-04-15 20:23:25 +00:00
2019-09-09 10:52:30 +00:00
mateApi :: Proxy MateAPI
mateApi = Proxy
2019-04-15 20:23:25 +00:00
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