mateamt/app/Main.hs

236 lines
7.1 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 DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
2019-05-13 20:50:24 +00:00
{-# LANGUAGE FlexibleContexts #-}
module Main where
2019-03-22 21:34:01 +00:00
2020-05-10 05:28:17 +00:00
import Prelude as P
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)
2020-04-18 22:49:30 +00:00
import Data.ByteString.Char8 as B8 hiding (putStrLn)
2019-10-27 21:45:07 +00:00
import qualified Data.Text as T
import Data.String
2021-07-12 11:29:40 +00:00
import Data.Yaml
2019-12-19 01:40:54 +00:00
import Data.Version (showVersion)
2020-04-18 22:49:30 +00:00
import Data.IP
2019-05-06 21:41:05 +00:00
2019-04-15 20:23:25 +00:00
import Database.PostgreSQL.Simple
2020-05-10 05:28:17 +00:00
import Database.PostgreSQL.Simple.Migration
import Database.PostgreSQL.Simple.Util
2019-04-15 20:23:25 +00:00
2021-07-12 11:29:40 +00:00
import Network.Socket (defaultPort)
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
2020-04-18 22:49:30 +00:00
import Network.Wai.Middleware.Throttle
2019-04-15 20:23:25 +00:00
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-10-27 21:45:07 +00:00
import Options.Applicative
2020-04-18 22:49:30 +00:00
import System.Clock (TimeSpec(..))
2020-05-16 14:12:49 +00:00
import System.Exit
2020-04-18 22:49:30 +00:00
2019-04-15 20:23:25 +00:00
-- internal imports
import API
2021-02-01 01:24:41 +00:00
import Util (initDB)
2019-04-15 20:23:25 +00:00
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
2020-04-18 22:49:30 +00:00
-- import Middleware
2019-04-15 20:23:25 +00:00
2019-12-19 01:40:54 +00:00
import Paths_mateamt (version)
2019-03-22 21:34:01 +00:00
main :: IO ()
2019-04-15 20:23:25 +00:00
main = do
2020-05-16 14:12:49 +00:00
(Options confLoc tMigLoc) <- execParser opts
2021-07-12 11:29:40 +00:00
raw <- B8.readFile (T.unpack confLoc)
case decodeEither' raw of
Left msg ->
2019-10-27 21:45:07 +00:00
error (T.unpack $ confLoc <> ":" <>
2021-07-12 11:29:40 +00:00
" error: " <>
fromString (prettyPrintParseException msg)
2019-10-27 21:45:07 +00:00
)
Right
(ServerConfig
db_host
db_port
db_name
db_user
db_passwd
sym
2021-07-12 11:29:40 +00:00
currency_fraction
2019-10-27 21:45:07 +00:00
lport
lhost
2020-04-18 22:49:30 +00:00
-- max_conn_per_client
2019-12-15 09:31:41 +00:00
block_registration
2021-07-12 11:29:40 +00:00
sendmail_path
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
2020-05-10 05:28:17 +00:00
-- tracker <- newTVarIO M.empty
migrationsExist <- existsTable conn "schema_migrations"
2020-08-24 07:43:22 +00:00
unless migrationsExist $ do
2020-05-10 05:28:17 +00:00
withTransaction conn $
void $ do
2021-07-12 11:29:40 +00:00
void $ runMigration $
2020-05-10 05:28:17 +00:00
MigrationContext MigrationInitialization True conn
2021-02-01 01:24:41 +00:00
initDB conn
2020-05-16 14:12:49 +00:00
-- validate Migrations
let migLoc = T.unpack tMigLoc
ok <- withTransaction conn $ runMigration $ MigrationContext
(MigrationValidation (MigrationDirectory migLoc)) True conn
case ok of
MigrationError err -> do
putStrLn ("Migration validation error: " ++ err)
2020-08-24 07:43:22 +00:00
putStrLn "Running Migrations!"
2020-05-16 14:12:49 +00:00
void $ withTransaction conn $ runMigration $
MigrationContext (MigrationDirectory migLoc) True conn
MigrationSuccess -> return ()
ok2 <- withTransaction conn $ runMigration $ MigrationContext
(MigrationValidation (MigrationDirectory migLoc)) True conn
case ok2 of
MigrationError err -> do
putStrLn ("Migration validation error: " ++ err)
2020-08-24 07:43:22 +00:00
putStrLn "MIgration failure! exiting..."
2020-05-16 14:12:49 +00:00
exitWith (ExitFailure 3)
MigrationSuccess -> do
2020-08-24 07:43:22 +00:00
putStrLn "Migration validation success!"
putStrLn "starting up..."
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) $
2020-04-18 22:49:30 +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
2019-12-19 01:40:54 +00:00
, rsCurrencySymbol = sym
2021-07-12 11:29:40 +00:00
, rsCurrencyFraction = currency_fraction
2019-12-19 01:40:54 +00:00
, rsSoftwareVersion = T.pack (showVersion version)
2021-07-12 11:29:40 +00:00
, rsSendmailPath = sendmail_path
2019-10-27 21:45:07 +00:00
}
2020-04-18 22:49:30 +00:00
expirationSpec = TimeSpec 5 0 -- five seconds
2021-07-12 11:29:40 +00:00
throt = (defaultThrottleSettings expirationSpec)
{ throttleSettingsRate = 10
, throttleSettingsPeriod = 1000
}
2021-07-12 11:29:40 +00:00
th <- initCustomThrottler throt
2020-04-18 22:49:30 +00:00
(\req ->
let headers = requestHeaders req
in case lookup "x-forwarded-for" headers of
Just addrs ->
2021-07-12 11:29:40 +00:00
let xaddr = fst (B8.break (== ',') addrs)
in Right $ Address $ toSockAddr (read (B8.unpack xaddr), defaultPort)
2020-04-18 22:49:30 +00:00
Nothing -> Right $ Address $ remoteHost req
)
runSettings settings (throttle th (app block_registration initState))
2019-10-27 21:45:07 +00:00
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-12-15 09:31:41 +00:00
app :: Bool -> ReadState -> Application
2019-05-06 21:41:05 +00:00
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
2019-12-15 09:31:41 +00:00
app block_registration 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-12-15 09:31:41 +00:00
(
if block_registration
then
const $ throwError $ err406
{ errBody = "User registration is not allowed."
}
else
userNew
) :<|>
2019-08-06 18:15:54 +00:00
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 :<|>
2019-12-11 23:47:46 +00:00
journalCheck :<|>
2019-09-07 18:05:24 +00:00
avatarGet :<|>
avatarInsert :<|>
avatarUpdate :<|>
2019-12-19 01:40:54 +00:00
avatarList :<|>
2020-07-19 06:27:15 +00:00
roleList :<|>
roleNew :<|>
roleUpdate :<|>
roleDelete :<|>
roleAssociationList :<|>
roleAssociationSubmit :<|>
roleAssociationDelete :<|>
2019-12-19 01:40:54 +00:00
metaGet
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