From c51e334bc5a537300d9421f43bd355850e2013b4 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 21 Jan 2016 08:44:04 +0000
Subject: Fixed Nats & new API

---
 server/src/Thermoprint/Server.hs | 95 ++++++++++++++++------------------------
 1 file changed, 37 insertions(+), 58 deletions(-)

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

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index 4018d17..eff6c3a 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -41,6 +41,8 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Sequence (Seq)
 import qualified Data.Sequence as Seq
+import Data.Sequence (Map)
+import qualified Data.Sequence as Map
 
 import qualified Network.Wai.Handler.Warp as Warp
 import Network.Wai (Application)
@@ -62,11 +64,16 @@ instance Default Config where
                , warpSettings = Warp.defaultSettings
                }
 
+data HandlerInput = HandlerInput { sqlPool :: ConnectionPool
+                                 }
+
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 Job
+    printer PrinterId
     content Printout
 Draft
+    title DraftTitle Maybe
     content Printout
 |]
 
@@ -90,93 +97,65 @@ thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams
           | otherwise = return cfg
 
       realMain (Config{..}) = enter io $ do
-        runSqlPool' (runMigrationSilent migrateAll) >>= mapM_ $(logWarn)
-        liftIO . Warp.runSettings warpSettings . serve thermoprintAPI $ enter (hoistNat io) thermoprintServer'
-
-
-runSqlPool' :: ( MonadBaseControl IO m
-               , MonadReader ConnectionPool m
-               ) => SqlPersistT m a -> m a
-runSqlPool' a = runSqlPool a =<< ask
+        sqlPool <- ask
+        runSqlPool (runMigrationSilent migrateAll) sqlPool >>= mapM_ $(logWarn)
+        let
+          handlerInput = HandlerInput
+            { sqlPool = sqlPool
+            }
+          io' :: ReaderT HandlerInput IO :~> IO
+          io' = runReaderTNat handlerInput
+        liftIO . Warp.runSettings warpSettings . serve thermoprintAPI $ enter (hoistNat io') thermoprintServer'
+
+type Handler = EitherT ServantErr (ReaderT HandlerInput IO)
 
 (<||>) :: Monad m => m a -> m b -> m (a :<|> b)
 (<||>) = liftM2 (:<|>)
 infixr 9 <||>
 
-
-thermoprintServer' :: ( Monad m
-                      ) => ServerT ThermoprintAPI (EitherT ServantErr m)
+thermoprintServer' :: ServerT ThermoprintAPI Handler
 thermoprintServer' = listPrinters
-                     :<|> queueJob <||> printerStatus
-                     :<|> listJobs
-                     :<|> getJob <||> jobStatus <||> getJobPrinter <||> deleteJob
+                     :<|> listJobs <||> queueJob
+                     :<|> getJob <||> jobStatus <||> deleteJob
                      :<|> (listDrafts :<|> addDraft)
-                     :<|> updateDraft <||> getDraft <||> deleteDraft
+                     :<|> updateDraft <||> getDraft <||> deleteDraft <||> printDraft
 
 
-listPrinters :: ( Monad m
-                ) => EitherT ServantErr m (Set PrinterId)
+listPrinters :: Handler (Set PrinterId)
 listPrinters = return Set.empty
 
-queueJob :: ( Monad m
-            ) => PrinterId
-            -> Printout
-            -> EitherT ServantErr m API.JobId
+queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId
 queueJob = return undefined
 
-printerStatus :: ( Monad m
-                 ) => PrinterId
-                 -> EitherT ServantErr m PrinterStatus
+printerStatus :: PrinterId -> Handler PrinterStatus
 printerStatus = return undefined
 
-listJobs :: ( Monad m
-            ) => Maybe PrinterId
-            -> Maybe API.JobId
-            -> Maybe API.JobId
-            -> EitherT ServantErr m (Seq API.JobId)
+listJobs :: Maybe PrinterId -> Maybe API.JobId -> Maybe API.JobId -> Handler (Seq (API.JobId, JobStatus))
 listJobs = return undefined
 
-getJob :: ( Monad m
-          ) => API.JobId
-          -> EitherT ServantErr m Printout
+getJob :: API.JobId -> Handler Printout
 getJob = return undefined
 
-jobStatus :: ( Monad m
-             ) => API.JobId
-             -> EitherT ServantErr m JobStatus
+jobStatus :: API.JobId -> Handler JobStatus
 jobStatus = return undefined
 
-getJobPrinter :: ( Monad m
-                 ) => API.JobId
-                 -> EitherT ServantErr m PrinterId
-getJobPrinter = return undefined
-
-deleteJob :: ( Monad m
-             ) => API.JobId
-             -> EitherT ServantErr m ()
+deleteJob :: API.JobId -> Handler ()
 deleteJob = return undefined
 
-listDrafts :: ( Monad m
-              ) => EitherT ServantErr m (Set API.DraftId)
+listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle))
 listDrafts = return undefined
 
-addDraft :: ( Monad m
-            ) => Printout
-            -> EitherT ServantErr m API.DraftId
+addDraft :: Maybe DraftTitle -> Printout -> Handler API.DraftId
 addDraft = return undefined
 
-updateDraft :: ( Monad m
-               ) => API.DraftId
-               -> Printout
-               -> EitherT ServantErr m ()
+updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler ()
 updateDraft = return undefined
 
-getDraft :: ( Monad m
-            ) => API.DraftId
-            -> EitherT ServantErr m Printout
+getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout)
 getDraft = return undefined
 
-deleteDraft :: ( Monad m
-               ) => API.DraftId
-               -> EitherT ServantErr m ()
+deleteDraft :: API.DraftId -> Handler ()
 deleteDraft = return undefined
+
+printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId
+printDraft = return undefined
-- 
cgit v1.2.3