From 08a6ee538ced1afb059491c7fd25f233999f5ca4 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sat, 23 Jan 2016 11:09:04 +0000
Subject: Split out database defs & minor cleanup

---
 server/src/Thermoprint/Server.hs | 65 ++++++++++++++++------------------------
 1 file changed, 26 insertions(+), 39 deletions(-)

(limited to 'server/src/Thermoprint/Server.hs')

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 (:<|>)
-- 
cgit v1.2.3