mirror of
https://github.com/graninas/Hydra.git
synced 2024-12-11 10:31:23 +03:00
121 lines
3.4 KiB
Haskell
121 lines
3.4 KiB
Haskell
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
|
|
module Astro.Server
|
|
( runAstroServer
|
|
, astroAPI
|
|
) where
|
|
|
|
import Control.Monad
|
|
import System.Process (readCreateProcess, shell)
|
|
import Network.Wai.Handler.Warp (run)
|
|
import Servant
|
|
import Data.Time
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import Data.Time.Clock (UTCTime)
|
|
import qualified Database.Beam as B
|
|
import qualified Database.Beam.Sqlite as BS
|
|
import qualified Database.Beam.Backend.SQL as B
|
|
import Database.Beam ((==.), (&&.), (<-.), (/=.), (==?.))
|
|
|
|
import Hydra.Prelude
|
|
import qualified Hydra.Domain as D
|
|
import qualified Hydra.Runtime as R
|
|
import qualified Hydra.Interpreters as R
|
|
import qualified Hydra.Language as L
|
|
|
|
import Astro.Config (loggerCfg, dbConfig)
|
|
import qualified Astro.API as API
|
|
import Astro.Domain.Meteor
|
|
import Astro.Domain.Asteroid
|
|
import Astro.Catalogue
|
|
import Astro.Types
|
|
|
|
type AstroAPI
|
|
= ( "meteors"
|
|
:> QueryParam "mass" Int
|
|
:> QueryParam "size" Int
|
|
:> Get '[JSON] Meteors
|
|
)
|
|
:<|>
|
|
( "meteor"
|
|
:> ReqBody '[JSON] API.MeteorTemplate
|
|
:> Post '[JSON] MeteorId
|
|
)
|
|
:<|>
|
|
( "asteroid"
|
|
:> ReqBody '[JSON] API.AsteroidTemplate
|
|
:> Post '[JSON] AsteroidId
|
|
)
|
|
|
|
astroAPI :: Proxy AstroAPI
|
|
astroAPI = Proxy
|
|
|
|
data Env = Env !R.AppRuntime !AppState
|
|
type AppHandler = ReaderT Env (ExceptT ServerError IO)
|
|
type AppServer = ServerT AstroAPI AppHandler
|
|
|
|
astroServer :: Env -> Server AstroAPI
|
|
astroServer env = hoistServer astroAPI (f env) astroServer'
|
|
where
|
|
f :: Env -> ReaderT Env (ExceptT ServerError IO) a -> Handler a
|
|
f env r = do
|
|
eResult <- liftIO $ (runExceptT $ runReaderT r env )
|
|
case eResult of
|
|
Left err -> throwError err
|
|
Right res -> pure res
|
|
|
|
astroBackendApp :: Env -> Application
|
|
astroBackendApp = serve astroAPI . astroServer
|
|
|
|
runApp :: L.AppL a -> AppHandler a
|
|
runApp flow = do
|
|
Env rt _ <- ask
|
|
eRes <- lift $ lift $ try $ R.runAppL rt flow
|
|
case eRes of
|
|
Left (err :: SomeException) -> do
|
|
liftIO $ putStrLn @String $ "Exception handled: " <> show err
|
|
throwError err500
|
|
Right res -> pure res
|
|
|
|
|
|
astroServer' :: AppServer
|
|
astroServer'
|
|
= meteors
|
|
:<|> meteor
|
|
:<|> asteroid
|
|
|
|
meteors :: Maybe Int -> Maybe Int -> AppHandler Meteors
|
|
meteors mbMass mbSize = runApp
|
|
$ withDB dbConfig
|
|
$ getMeteors mbMass mbSize
|
|
|
|
meteor :: API.MeteorTemplate -> AppHandler MeteorId
|
|
meteor m = runApp
|
|
$ withDB dbConfig
|
|
$ createMeteor m
|
|
|
|
asteroid :: API.AsteroidTemplate -> AppHandler AsteroidId
|
|
asteroid a = error "Not implemented yet."
|
|
|
|
prepareSQLiteDB :: IO ()
|
|
prepareSQLiteDB = do
|
|
putStrLn @String "Copying astro_template.db to /tmp/astro.db..."
|
|
eRes <- try $ void $ readCreateProcess (shell "cp ./app/astro/astro_template.db /tmp/astro.db") ""
|
|
case eRes of
|
|
Left (err :: SomeException) -> do
|
|
putStrLn @String $ "Exception got: " <> show err
|
|
error $ "Exception got: " <> show err
|
|
Right _ -> pure ()
|
|
|
|
runAstroServer :: IO ()
|
|
runAstroServer = do
|
|
prepareSQLiteDB
|
|
putStrLn @String "Starting Astro App Server..."
|
|
R.withAppRuntime (Just loggerCfg) $ \rt -> do
|
|
appSt <- R.runAppL rt $ initState AppConfig
|
|
run 8080 $ astroBackendApp $ Env rt appSt
|