mateamt/app/Main.hs

213 lines
5.7 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-10-27 21:45:07 +00:00
import Data.Set as S (empty)
2019-10-31 22:58:50 +00:00
import qualified Data.Map.Lazy as M
2019-10-27 21:45:07 +00:00
import Data.ByteString.Lazy as BL hiding (putStrLn)
import qualified Data.Text as T
import Data.String
import Data.YAML
2019-05-06 21:41:05 +00:00
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-10-31 22:58:50 +00:00
import Network.Socket (SockAddr(..))
2019-04-15 20:23:25 +00:00
2019-05-08 23:24:58 +00:00
import Control.Monad.Reader
2019-10-31 22:58:50 +00:00
import Control.Concurrent.STM (atomically)
2019-05-06 21:41:05 +00:00
import Control.Concurrent.STM.TVar
2019-10-27 21:45:07 +00:00
import Options.Applicative
2019-04-15 20:23:25 +00:00
-- internal imports
import API
import Model as M
2019-10-27 21:45:07 +00:00
import AppTypes
2019-04-15 20:23:25 +00:00
import Types
2019-08-10 08:37:45 +00:00
import Control
2019-10-31 14:42:15 +00:00
import Janitor
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
2019-10-27 21:45:07 +00:00
(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
2019-10-31 22:58:50 +00:00
max_conn_per_client
2019-10-27 21:45:07 +00:00
) -> 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
2019-10-31 22:58:50 +00:00
tracker <- newTVarIO M.empty
2019-10-27 21:45:07 +00:00
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
2019-10-31 14:42:15 +00:00
forkCleanProcess conn store
2019-10-27 21:45:07 +00:00
withStdoutLogger $ \ilog -> do
let settings = setPort (fromIntegral lport) $
setHost (fromString $ T.unpack lhost) $
2019-10-31 22:58:50 +00:00
setOnOpen (addToTracker tracker max_conn_per_client) $
setOnClose (removeFromTracker tracker) $
2019-10-27 21:45:07 +00:00
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"
)
2019-04-15 20:23:25 +00:00
2019-10-31 22:58:50 +00:00
addToTracker
:: TVar (M.Map (Word, Word, Word, Word) Word)
-> Word
-> SockAddr
-> IO Bool
addToTracker tracker maxconn saddr = do
let laddr = translateAddr saddr
(nmap, accept) <- atomically $ do
tmap <- readTVar tracker
let (nmap, accept) = case tmap M.!? laddr of
Just val ->
if val < maxconn
then
(M.adjust (const $ val + 1) laddr tmap, True)
else
(tmap, False)
Nothing ->
(M.insert laddr 1 tmap, True)
writeTVar tracker nmap
return (nmap, accept)
print nmap
return accept
translateAddr
:: (Num a, Num b, Num c, Num d)
=> SockAddr
-> (a, b, c, d)
translateAddr saddr =
case saddr of
SockAddrInet _ addr -> (0, 0, 0, fromIntegral addr)
SockAddrInet6 _ _ (a1, a2, a3, a4) _ ->
(fromIntegral a1, fromIntegral a2, fromIntegral a3, fromIntegral a4)
_ -> error "Not made for sockets and the like"
removeFromTracker
:: TVar (M.Map (Word, Word, Word, Word) Word)
-> SockAddr
-> IO ()
removeFromTracker tracker saddr = do
let laddr = translateAddr saddr
atomically $ do
tmap <- readTVar tracker
let num = tmap M.! laddr
nmap = if num -1 > 0
then
M.adjust (const $ num - 1) laddr tmap
else
M.delete laddr tmap
writeTVar tracker nmap
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 :<|>
2019-09-16 06:59:57 +00:00
authManageList :<|>
authManageNewAuth :<|>
authManageDeleteAuth :<|>
2019-08-06 18:15:54 +00:00
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 :<|>
productShortList :<|>
2019-08-06 18:15:54 +00:00
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-09-15 12:59:22 +00:00
authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
2019-05-09 14:53:19 +00:00
authProxy = Proxy
2019-05-13 20:50:24 +00:00
genAuthServerContext
:: Connection
2019-09-15 12:59:22 +00:00
-> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
2019-05-13 20:50:24 +00:00
genAuthServerContext conn = authHandler conn Servant.:. EmptyContext
2019-04-17 05:51:15 +00:00
2019-09-15 12:59:22 +00:00
type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod)
2019-04-17 05:51:15 +00:00
2019-09-15 12:59:22 +00:00
authHandler :: Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
2019-05-13 20:50:24 +00:00
authHandler conn = mkAuthHandler handler
2019-04-17 05:51:15 +00:00
where
2019-09-15 12:59:22 +00:00
handler :: Request -> Handler (Maybe (Int, AuthMethod))
2019-04-17 05:51:15 +00:00
handler req = do
let headers = requestHeaders req
2019-10-14 20:50:42 +00:00
case lookup "Authentication" headers of
Just hh ->
validateToken hh conn
2019-05-13 20:50:24 +00:00
_ ->
return Nothing