mateamt/src/Main.hs
2019-08-14 18:04:00 +02:00

116 lines
2.6 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
import Control
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 :<|>
userRecharge :<|>
productNew :<|>
productOverview :<|>
productStockRefill :<|>
productStockUpdate :<|>
productList :<|>
buy :<|>
journalShow
)
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