From 08a6ee538ced1afb059491c7fd25f233999f5ca4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 23 Jan 2016 11:09:04 +0000 Subject: Split out database defs & minor cleanup --- server/src/Thermoprint/Server.hs | 65 +++++++++++++------------------ server/src/Thermoprint/Server/Database.hs | 24 ++++++++++++ server/thermoprint-server.cabal | 2 + server/thermoprint-server.nix | 4 +- 4 files changed, 54 insertions(+), 41 deletions(-) create mode 100644 server/src/Thermoprint/Server/Database.hs (limited to 'server') diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 0918e83..d1ee6ee 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -1,15 +1,8 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} module Thermoprint.Server ( thermoprintServer @@ -28,6 +21,8 @@ import Control.Monad ((<=<), mapM_, liftM2) import Prelude hiding ((.), id) import Control.Category +import Data.Maybe (maybe) + import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Resource @@ -45,6 +40,9 @@ import qualified Data.Sequence as Seq import Data.Map (Map) import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T (pack) + import qualified Network.Wai.Handler.Warp as Warp import Network.Wai (Application) @@ -52,12 +50,13 @@ import Servant import Servant.Server import Servant.Server.Internal.Enter -import Database.Persist -import Database.Persist.Sql -import Database.Persist.TH +import Database.Persist.Sql (runMigrationSilent, ConnectionPool, runSqlPool) + -data Config = Config { dyreError :: Maybe String - , warpSettings :: Warp.Settings +import Thermoprint.Server.Database + +data Config = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error + , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour } instance Default Config where @@ -69,48 +68,36 @@ data HandlerInput = HandlerInput { sqlPool :: ConnectionPool } -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -Job - content Printout -Draft - title DraftTitle Maybe - content Printout -|] - - thermoprintServer :: ( MonadLoggerIO m , MonadIO m , MonadBaseControl IO m , MonadReader ConnectionPool m ) => (m :~> IO) -> Config -> IO () +-- ^ Run the server thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams { Dyre.projectName = "thermoprint-server" - , Dyre.realMain = realMain <=< handleDyreErrors + , Dyre.realMain = realMain , Dyre.showError = (\cfg msg -> cfg { dyreError = Just msg }) } where - handleDyreErrors cfg@(Config{..}) - | Just msg <- dyreError = do - hPutStrLn stderr msg - exitFailure - undefined - | otherwise = return cfg - - realMain (Config{..}) = enter io $ do + realMain Config{..} = unNat io $ do + maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError + sqlPool <- ask - runSqlPool (runMigrationSilent migrateAll) sqlPool >>= mapM_ ($(logWarnS) "DB") - logFunc <- askLoggerIO + + runSqlPool (runMigrationSilent migrateAll) sqlPool >>= mapM_ ($(logWarnS) "DB") let handlerInput = HandlerInput { sqlPool = sqlPool } - io' :: ReaderT HandlerInput (LoggingT IO) :~> IO + io' :: ProtoHandler :~> IO io' = Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput liftIO . Warp.runSettings warpSettings . serve thermoprintAPI $ enter (hoistNat io') thermoprintServer' -type Handler = EitherT ServantErr (ReaderT HandlerInput (LoggingT IO)) +type ProtoHandler = ReaderT HandlerInput (LoggingT IO) +type Handler = EitherT ServantErr ProtoHandler (<||>) :: Monad m => m a -> m b -> m (a :<|> b) (<||>) = liftM2 (:<|>) diff --git a/server/src/Thermoprint/Server/Database.hs b/server/src/Thermoprint/Server/Database.hs new file mode 100644 index 0000000..61179e6 --- /dev/null +++ b/server/src/Thermoprint/Server/Database.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Thermoprint.Server.Database + ( Job(..), JobId + , Draft(..), DraftId + , migrateAll + ) where + +import Thermoprint.API (Printout, DraftTitle) + +import Database.Persist.TH + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +Job + content Printout +Draft + title DraftTitle Maybe + content Printout +|] diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index 0aa1870..45e57a6 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -18,6 +18,7 @@ cabal-version: >=1.10 library exposed-modules: Thermoprint.Server + , Thermoprint.Server.Database -- other-modules: -- other-extensions: build-depends: base >=4.8 && <5 @@ -35,6 +36,7 @@ library , monad-logger >=0.3.13 && <1 , containers >=0.5.6 && <1 , either >=4.4.1 && <5 + , text >=1.2.1 && <2 hs-source-dirs: src default-language: Haskell2010 diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix index c6a6224..c48ec7f 100644 --- a/server/thermoprint-server.nix +++ b/server/thermoprint-server.nix @@ -1,6 +1,6 @@ { mkDerivation, base, containers, data-default-class, dyre, either , monad-logger, mtl, persistent, persistent-sqlite -, persistent-template, resourcet, servant-server, stdenv +, persistent-template, resourcet, servant-server, stdenv, text , thermoprint-spec, transformers, wai, warp }: mkDerivation { @@ -11,7 +11,7 @@ mkDerivation { isExecutable = true; libraryHaskellDepends = [ base containers data-default-class dyre either monad-logger mtl - persistent persistent-template resourcet servant-server + persistent persistent-template resourcet servant-server text thermoprint-spec transformers wai warp ]; executableHaskellDepends = [ -- cgit v1.2.3