mateamt/app/Main.hs
2024-09-06 02:18:35 +02:00

271 lines
7.9 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Main where
import Prelude as P
import Crypto.JWT hiding (Context, header)
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM (newTQueueIO)
import Control.Concurrent (forkIO)
import Control.Lens hiding (Context)
import Control.Monad (void, unless)
import Control.Monad.Reader
import Servant
import Servant.Server.Experimental.Auth
import qualified Servant.OpenApi as OA
import Servant.Swagger.UI
import Servant.RawM.Server
import Data.Set as S (empty)
import qualified Data.ByteString.Lazy as B
import Data.ByteString.Char8 as B8 hiding (putStrLn)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.String
import Data.Yaml
import Data.Version (showVersion)
import qualified Data.OpenApi as OA hiding (Server)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.Migration
import Database.PostgreSQL.Simple.Util
import Network.Wai
import Network.Wai.Logger
import Network.Wai.Handler.Warp
import Options.Applicative
import System.Clock (TimeSpec(..))
import System.Exit
-- internal imports
import API
import Util (initDB, engageCourier)
import Model as M
import AppTypes
import Types
import Control
import Janitor
import Paths_mateamt (version)
main :: IO ()
main = do
(Options confLoc tMigLoc) <- execParser opts
raw <- B8.readFile (T.unpack confLoc)
case decodeEither' raw of
Left msg ->
error (T.unpack $ confLoc <> ":" <>
" error: " <>
fromString (prettyPrintParseException msg)
)
Right
(ServerConfig
db_host
db_port
db_name
db_user
db_passwd
sym
currency_fraction
lport
lhost
-- max_conn_per_client
-- block_registration
sendmail_path
jwt_secret
) -> 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
-- tracker <- newTVarIO M.empty
migrationsExist <- existsTable conn "schema_migrations"
unless migrationsExist $ do
withTransaction conn $
void $ do
void $ runMigration $
MigrationContext MigrationInitialization True conn
initDB conn
-- 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)
putStrLn "Running Migrations!"
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)
putStrLn "MIgration failure! exiting..."
exitWith (ExitFailure 3)
MigrationSuccess -> do
putStrLn "Migration validation success!"
putStrLn "starting up..."
forkCleanProcess conn store
mailQueue <- newTQueueIO
void $ forkIO $ engageCourier mailQueue sendmail_path
withStdoutLogger $ \ilog -> do
let settings = setPort (fromIntegral lport) $
setHost (fromString $ T.unpack lhost) $
-- setOnOpen (addToTracker tracker max_conn_per_client) $
-- setOnClose (removeFromTracker tracker) $
setLogger ilog defaultSettings
initState = ReadState
{ rsConnection = conn
, rsTicketStore = store
, rsCurrencySymbol = sym
, rsCurrencyFraction = currency_fraction
, rsSoftwareVersion = T.pack (showVersion version)
, rsSendmailPath = sendmail_path
, rsMailQueue = mailQueue
, rsJWTSecret =
fromOctets . B.fromStrict $ TE.encodeUtf8 jwt_secret
}
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 combinedAPI
(genAuthServerContext (rsJWTSecret initState) (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 =
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 :<|>
getSettings :<|>
Control.updateSettings :<|>
metaGet
mateSwagger :: OA.OpenApi
mateSwagger = OA.toOpenApi mateAPI
& 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
type CombinedAPI = MateAPI :<|> SwaggerSchemaUI "swagger-ui" "swagger.json"
authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
authProxy = Proxy
genAuthServerContext
:: JWK
-> Connection
-> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
genAuthServerContext key conn = authHandler key conn Servant.:. EmptyContext
type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod)
authHandler :: JWK -> Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
authHandler key conn = mkAuthHandler handler
where
handler :: Request -> Handler (Maybe (Int, AuthMethod))
handler req = do
let headers = requestHeaders req
case lookup "Authorization" headers of
Just hh -> do
validateToken (B8.drop 7 hh) key conn
_ ->
return Nothing
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))
instance OA.HasOpenApi (JWS Identity () JWSHeader) where
toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent))