83 lines
2.5 KiB
Haskell
83 lines
2.5 KiB
Haskell
module Core where
|
|
|
|
import Control.Exception (IOException)
|
|
import Control.Monad.Catch (catch)
|
|
import Data.Aeson (FromJSON, ToJSON)
|
|
import Data.Pool (Pool)
|
|
import qualified Data.Text as T
|
|
import Database.PostgreSQL.Simple (Connection, Query)
|
|
import Database.PostgreSQL.Simple.FromField (FromField)
|
|
import Database.PostgreSQL.Simple.FromRow (FromRow, field, fromRow)
|
|
import Database.PostgreSQL.Simple.ToField (ToField, toField)
|
|
import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
|
|
import Effectful
|
|
import Effectful.Error.Static (Error, throwError)
|
|
import Effectful.Reader.Static (Reader)
|
|
import GHC.Generics (Generic)
|
|
import Servant hiding ((:>), throwError)
|
|
|
|
--
|
|
-- Core data types
|
|
--
|
|
type AppEff =
|
|
Eff '[ Logger
|
|
, Database
|
|
, Reader AppEnv
|
|
, Error ServerError
|
|
, IOE
|
|
]
|
|
|
|
data AppEnv = AppEnv { pool :: Pool Connection }
|
|
|
|
newtype UserId = UserId Int
|
|
deriving (Show, Generic, FromField, ToField, FromHttpApiData, ToHttpApiData)
|
|
|
|
instance ToJSON UserId
|
|
instance FromJSON UserId
|
|
instance ToRow UserId
|
|
instance FromRow UserId
|
|
|
|
data User = User { userId :: UserId, userName :: T.Text}
|
|
deriving (Show, Generic)
|
|
|
|
instance FromRow User where
|
|
fromRow = User <$> field <*> field
|
|
instance ToRow User where
|
|
toRow (User uid name) = toRow (uid, name)
|
|
|
|
instance ToJSON User
|
|
instance FromJSON User
|
|
|
|
data Database :: Effect where
|
|
DatabaseInit
|
|
:: Database (Eff es) ()
|
|
DatabaseRead
|
|
:: (ToField a, Show a, FromRow b) => (Query, a) -> Database (Eff es) [b]
|
|
DatabaseRead_
|
|
:: (FromRow b) => Query -> Database (Eff es) [b]
|
|
DatabaseWrite
|
|
:: (ToRow a, Show a) => (Query, a) -> Database (Eff es) ()
|
|
|
|
data Logger :: Effect where
|
|
WriteLog :: LogLevel -> String -> Logger (Eff es) ()
|
|
|
|
data LogLevel = Info | Warning | Error
|
|
deriving (Show, Eq)
|
|
|
|
instance ToField LogLevel where
|
|
toField level = toField (T.pack (show level))
|
|
|
|
-- Utility
|
|
liftIOE :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a
|
|
-- Lift IO into Eff and catch IOExceptions
|
|
liftIOE m = liftIO m `catch` \(e::IOException) -> do
|
|
-- Log IOExceptions to stdout
|
|
liftIO $ putStrLn $ "ERROR Exception: " ++ show e
|
|
-- Throw a custom Servant ServerError
|
|
throwError $ ServerError
|
|
{ errHTTPCode = 500
|
|
, errReasonPhrase = "Internal Server Error"
|
|
, errBody = "This incident will be investigated."
|
|
, errHeaders = []
|
|
}
|