153 lines
4 KiB
Haskell
153 lines
4 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Main where
|
|
|
|
import Servant
|
|
import Servant.Server.Experimental.Auth
|
|
|
|
import Data.Set as S (empty)
|
|
import Data.ByteString.Lazy as BL hiding (putStrLn)
|
|
import qualified Data.Text as T
|
|
import Data.String
|
|
import Data.YAML
|
|
|
|
import Database.PostgreSQL.Simple
|
|
|
|
import Network.Wai
|
|
import Network.Wai.Logger
|
|
import Network.Wai.Handler.Warp
|
|
|
|
import Control.Monad.Reader
|
|
|
|
import Control.Concurrent.STM.TVar
|
|
|
|
import Options.Applicative
|
|
|
|
-- internal imports
|
|
|
|
import API
|
|
import Model as M
|
|
|
|
import AppTypes
|
|
import Types
|
|
import Control
|
|
|
|
main :: IO ()
|
|
main = do
|
|
(Options confLoc) <- execParser opts
|
|
raw <- BL.readFile (T.unpack confLoc)
|
|
case decode1 raw of
|
|
Left (loc, msg) ->
|
|
error (T.unpack $ confLoc <> ":" <>
|
|
fromString (prettyPosWithSource loc raw " error") <>
|
|
fromString msg
|
|
)
|
|
Right
|
|
(ServerConfig
|
|
db_host
|
|
db_port
|
|
db_name
|
|
db_user
|
|
db_passwd
|
|
sym
|
|
lport
|
|
lhost
|
|
) -> do
|
|
conn <- connectPostgreSQL (
|
|
"host='" <> fromString (T.unpack db_host) <> "' " <>
|
|
"port=" <> fromString (show db_port) <> " " <>
|
|
"dbname='" <> fromString (T.unpack db_name) <> "' " <>
|
|
"user='" <> fromString (T.unpack db_user) <> "' " <>
|
|
"password='" <> fromString (T.unpack db_passwd) <> "'"
|
|
)
|
|
store <- newTVarIO S.empty
|
|
void $ execute_ conn initAvatar
|
|
void $ execute_ conn initUser
|
|
void $ execute_ conn initProduct
|
|
void $ execute_ conn initToken
|
|
void $ execute_ conn initAuthData
|
|
void $ execute_ conn initAmount
|
|
void $ execute_ conn initJournal
|
|
withStdoutLogger $ \ilog -> do
|
|
let settings = setPort (fromIntegral lport) $
|
|
setHost (fromString $ T.unpack lhost) $
|
|
setLogger ilog defaultSettings
|
|
initState = ReadState
|
|
{ rsConnection = conn
|
|
, rsTicketStore = store
|
|
}
|
|
runSettings settings (app initState)
|
|
where
|
|
opts = info (options <**> helper)
|
|
( fullDesc
|
|
<> progDesc "Run the \"mateamt\" API-Server."
|
|
<> header "mateamt - Your friendly mate distribution office"
|
|
)
|
|
|
|
app :: ReadState -> Application
|
|
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
|
|
app initState =
|
|
serveWithContext mateApi (genAuthServerContext (rsConnection initState)) $
|
|
hoistServerWithContext
|
|
mateApi
|
|
authProxy
|
|
(`runReaderT` initState)
|
|
( authGet :<|>
|
|
authSend :<|>
|
|
authLogout :<|>
|
|
|
|
authManageList :<|>
|
|
authManageNewAuth :<|>
|
|
authManageDeleteAuth :<|>
|
|
|
|
userNew :<|>
|
|
userGet :<|>
|
|
userUpdate :<|>
|
|
userList :<|>
|
|
userRecharge :<|>
|
|
userTransfer :<|>
|
|
|
|
productNew :<|>
|
|
productOverview :<|>
|
|
productStockRefill :<|>
|
|
productStockUpdate :<|>
|
|
productList :<|>
|
|
productShortList :<|>
|
|
|
|
buy :<|>
|
|
|
|
journalShow :<|>
|
|
|
|
avatarGet :<|>
|
|
avatarInsert :<|>
|
|
avatarUpdate :<|>
|
|
avatarList
|
|
)
|
|
|
|
mateApi :: Proxy MateAPI
|
|
mateApi = Proxy
|
|
|
|
authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
|
|
authProxy = Proxy
|
|
|
|
genAuthServerContext
|
|
:: Connection
|
|
-> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
|
|
genAuthServerContext conn = authHandler conn Servant.:. EmptyContext
|
|
|
|
type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod)
|
|
|
|
authHandler :: Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
|
|
authHandler conn = mkAuthHandler handler
|
|
where
|
|
handler :: Request -> Handler (Maybe (Int, AuthMethod))
|
|
handler req = do
|
|
let headers = requestHeaders req
|
|
case lookup "Authentication" headers of
|
|
Just hh ->
|
|
validateToken hh conn
|
|
_ ->
|
|
return Nothing
|