Split out database defs & minor cleanup

4 files changed, 54 insertions, 41 deletions

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 = [