Split out Thermoprint.Server.API

3 files changed, 117 insertions, 93 deletions

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index d1ee6ee..419679c 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -14,47 +14,34 @@ module Thermoprint.Server
 import Data.Default.Class
 import qualified Config.Dyre as Dyre
 
-import System.IO (hPutStrLn, stderr)
-import System.Exit (exitFailure)
-
-import Control.Monad ((<=<), mapM_, liftM2)
-import Prelude hiding ((.), id)
-import Control.Category
+import Control.Monad (mapM_)
 
 import Data.Maybe (maybe)
 
+import Control.Monad.Trans.Resource
 import Control.Monad.Logger
 import Control.Monad.Reader
-import Control.Monad.Trans.Resource
-import Control.Monad.Trans.Either
 import Control.Monad.IO.Class
-
-import Data.Functor.Compose
-
-import Thermoprint.API hiding (JobId(..), DraftId(..))
-import qualified Thermoprint.API as API (JobId(..), DraftId(..))
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Sequence (Seq)
-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)
 
-import Servant
-import Servant.Server
-import Servant.Server.Internal.Enter
+import Servant.Server (serve)
+import Servant.Server.Internal.Enter (enter, (:~>)(..))
 
 import Database.Persist.Sql (runMigrationSilent, ConnectionPool, runSqlPool)
 
 
+import Thermoprint.API (thermoprintAPI)
+
 import Thermoprint.Server.Database
+import qualified Thermoprint.Server.API as API (thermoprintServer)
+import Thermoprint.Server.API hiding (thermoprintServer)
 
+  
 data Config = Config { dyreError    :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error
                      , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour
                      }
@@ -64,9 +51,6 @@ instance Default Config where
                , warpSettings = Warp.defaultSettings
                }
 
-data HandlerInput = HandlerInput { sqlPool :: ConnectionPool
-                                 }
-
 
 thermoprintServer :: ( MonadLoggerIO m
                      , MonadIO m
@@ -82,70 +66,5 @@ thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams
     where
       realMain Config{..} = unNat io $ do
         maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError
-        
-        sqlPool <- ask
-        logFunc <- askLoggerIO
-
-        runSqlPool (runMigrationSilent migrateAll) sqlPool >>= mapM_ ($(logWarnS) "DB")
-        
-        let
-          handlerInput = HandlerInput
-            { sqlPool = sqlPool
-            }
-          io' :: ProtoHandler :~> IO
-          io' = Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput
-        liftIO . Warp.runSettings warpSettings . serve thermoprintAPI $ enter (hoistNat io') thermoprintServer'
-
-type ProtoHandler = ReaderT HandlerInput (LoggingT IO)
-type Handler      = EitherT ServantErr ProtoHandler
-
-(<||>) :: Monad m => m a -> m b -> m (a :<|> b)
-(<||>) = liftM2 (:<|>)
-infixr 9 <||>
-
-thermoprintServer' :: ServerT ThermoprintAPI Handler
-thermoprintServer' = listPrinters
-                     :<|> (listJobs :<|> queueJob)
-                     :<|> getJob <||> jobStatus <||> deleteJob
-                     :<|> (listDrafts :<|> addDraft)
-                     :<|> updateDraft <||> getDraft <||> deleteDraft <||> printDraft
-
-
-listPrinters :: Handler (Map PrinterId PrinterStatus)
-listPrinters = return $ Map.fromList [(1, Available), (7, Available), (3, Available)]
-
-queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId
-queueJob = return undefined
-
-printerStatus :: PrinterId -> Handler PrinterStatus
-printerStatus = return undefined
-
-listJobs :: Maybe PrinterId -> Maybe API.JobId -> Maybe API.JobId -> Handler (Seq (API.JobId, JobStatus))
-listJobs = return undefined
-
-getJob :: API.JobId -> Handler Printout
-getJob = return undefined
-
-jobStatus :: API.JobId -> Handler JobStatus
-jobStatus = return undefined
-
-deleteJob :: API.JobId -> Handler ()
-deleteJob = return undefined
-
-listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle))
-listDrafts = return undefined
-
-addDraft :: Maybe DraftTitle -> Printout -> Handler API.DraftId
-addDraft = return undefined
-
-updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler ()
-updateDraft = return undefined
-
-getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout)
-getDraft = return undefined
-
-deleteDraft :: API.DraftId -> Handler ()
-deleteDraft = return undefined
-
-printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId
-printDraft = return undefined
+        mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask
+        liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat
diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs
new file mode 100644
index 0000000..9559ad1
--- /dev/null
+++ b/server/src/Thermoprint/Server/API.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE TypeOperators    #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell  #-}
+
+module Thermoprint.Server.API
+       ( ProtoHandler, Handler
+       , thermoprintServer
+       , handlerNat
+       ) where
+
+import Thermoprint.API hiding (JobId(..), DraftId(..))
+import qualified Thermoprint.API as API (JobId(..), DraftId(..))
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Servant
+import Servant.Server
+import Servant.Server.Internal.Enter
+
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Either
+import Control.Monad.IO.Class
+
+import Control.Monad ((<=<), liftM2)
+import Prelude hiding ((.), id)
+import Control.Category
+
+import Database.Persist
+import Database.Persist.Sql
+
+type ProtoHandler = ReaderT HandlerInput (LoggingT IO)
+type Handler      = EitherT ServantErr ProtoHandler
+
+data HandlerInput = HandlerInput { sqlPool :: ConnectionPool
+                                 }
+
+handlerNat :: ( MonadReader ConnectionPool m
+              , MonadLoggerIO m
+              ) => m (Handler :~> EitherT ServantErr IO)
+handlerNat = do
+  sqlPool <- ask
+  logFunc <- askLoggerIO
+  let
+    handlerInput = HandlerInput
+      { sqlPool = sqlPool
+      }
+    protoNat :: ProtoHandler :~> IO
+    protoNat = Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput
+  return $ hoistNat protoNat
+
+thermoprintServer :: ServerT ThermoprintAPI Handler
+thermoprintServer = listPrinters
+                     :<|> (listJobs :<|> queueJob)
+                     :<|> getJob <||> jobStatus <||> deleteJob
+                     :<|> (listDrafts :<|> addDraft)
+                     :<|> updateDraft <||> getDraft <||> deleteDraft <||> printDraft
+  where
+    (<||>) :: Monad m => m a -> m b -> m (a :<|> b)
+    (<||>) = liftM2 (:<|>)
+    infixr 9 <||>
+
+listPrinters :: Handler (Map PrinterId PrinterStatus)
+listPrinters = return $ Map.fromList [(1, Available), (7, Available), (3, Available)]
+
+queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId
+queueJob = return undefined
+
+printerStatus :: PrinterId -> Handler PrinterStatus
+printerStatus = return undefined
+
+listJobs :: Maybe PrinterId -> Maybe API.JobId -> Maybe API.JobId -> Handler (Seq (API.JobId, JobStatus))
+listJobs = return undefined
+
+getJob :: API.JobId -> Handler Printout
+getJob = return undefined
+
+jobStatus :: API.JobId -> Handler JobStatus
+jobStatus = return undefined
+
+deleteJob :: API.JobId -> Handler ()
+deleteJob = return undefined
+
+listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle))
+listDrafts = return undefined
+
+addDraft :: Maybe DraftTitle -> Printout -> Handler API.DraftId
+addDraft = return undefined
+
+updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler ()
+updateDraft = return undefined
+
+getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout)
+getDraft = return undefined
+
+deleteDraft :: API.DraftId -> Handler ()
+deleteDraft = return undefined
+
+printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId
+printDraft = return undefined
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index 45e57a6..45f24d3 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -19,6 +19,7 @@ cabal-version:       >=1.10
 library
   exposed-modules:     Thermoprint.Server
                      , Thermoprint.Server.Database
+                     , Thermoprint.Server.API
   -- other-modules:       
   -- other-extensions:    
   build-depends:       base >=4.8 && <5