mateamt/app/Main.hs

272 lines
8.2 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 #-}
2022-07-17 19:28:22 +00:00
{-# LANGUAGE TypeOperators #-}
2019-05-13 20:50:24 +00:00
{-# LANGUAGE FlexibleContexts #-}
2022-07-17 19:28:22 +00:00
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
2022-07-18 04:34:46 +00:00
{-# LANGUAGE AllowAmbiguousTypes #-}
module Main where
2019-03-22 21:34:01 +00:00
2020-05-10 05:28:17 +00:00
import Prelude as P
import Control.Concurrent.STM (newTQueueIO)
import Control.Concurrent (forkIO)
2019-04-15 20:23:25 +00:00
import Servant
2019-04-17 05:51:15 +00:00
import Servant.Server.Experimental.Auth
2022-07-17 19:28:22 +00:00
import qualified Servant.OpenApi as OA
2022-07-18 04:34:46 +00:00
import Servant.Swagger.UI
2022-07-17 19:28:22 +00:00
import Servant.RawM
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
2022-07-17 19:28:22 +00:00
import qualified Data.OpenApi as OA hiding (Server)
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
2022-07-17 19:28:22 +00:00
import Control.Lens hiding (Context)
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
import Util (initDB, engageCourier)
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
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
-- 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
mailQueue <- newTQueueIO
void $ forkIO $ engageCourier mailQueue sendmail_path
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
, rsMailQueue = mailQueue
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 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
app :: ReadState -> Application
2019-05-06 21:41:05 +00:00
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
2022-07-18 04:34:46 +00:00
app initState =
serveWithContext combinedAPI (genAuthServerContext (rsConnection initState)) server
where
server :: Server CombinedAPI
server = appToServer initState mateAPI thisApi :<|>
swaggerSchemaUIServer mateSwagger
appToServer initState myApi =
hoistServerWithContext
myApi
authProxy
(`runReaderT` initState)
thisApi :: ServerT MateAPI MateHandler
thisApi =
authGet :<|>
authSend :<|>
authLogout :<|>
authManageList :<|>
authManageNewAuth :<|>
authManageDeleteAuth :<|>
userNew :<|>
userGet :<|>
userUpdate :<|>
userList :<|>
userRecharge :<|>
userTransfer :<|>
productNew :<|>
productOverview :<|>
productStockRefill :<|>
productStockUpdate :<|>
productList :<|>
productShortList :<|>
buy :<|>
journalShow :<|>
journalCheck :<|>
avatarGet :<|>
avatarInsert :<|>
avatarUpdate :<|>
avatarList :<|>
roleList :<|>
roleNew :<|>
roleUpdate :<|>
roleDelete :<|>
roleAssociationList :<|>
roleAssociationSubmit :<|>
roleAssociationDelete :<|>
2022-07-24 21:11:47 +00:00
getSettings :<|>
Control.updateSettings :<|>
2022-07-18 04:34:46 +00:00
metaGet
mateSwagger :: OA.OpenApi
mateSwagger = OA.toOpenApi mateAPI
2022-07-17 19:28:22 +00:00
& OA.info.OA.title .~ "Mateamt API"
& OA.info.OA.version .~ "1.0"
& OA.info.OA.description ?~ "AN API to buy Mate and other products from your local Hackerspace or event."
& OA.info.OA.license ?~ ("AGPL" & OA.url ?~ OA.URL "https://www.gnu.org/licenses/agpl-3.0-standalone.html")
mateAPI :: Proxy MateAPI
mateAPI = Proxy
combinedAPI :: Proxy CombinedAPI
combinedAPI = Proxy
2022-07-18 04:34:46 +00:00
type CombinedAPI = MateAPI :<|> SwaggerSchemaUI "swagger-ui" "swagger.json"
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
2022-07-17 19:28:22 +00:00
instance OA.HasOpenApi sub => OA.HasOpenApi (AuthProtect "header-auth" :> sub) where
toOpenApi _ = OA.toOpenApi (Proxy :: Proxy sub)
instance OA.HasOpenApi (RawM' Application) where
toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent))