Nonfunctional API framework for server

2 files changed, 148 insertions, 24 deletions

diff --git a/server/src/Main.hs b/server/src/Main.hs
deleted file mode 100644
index e392fe1..0000000
--- a/server/src/Main.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main (main) where
-
-import Thermoprint.Server
-
-main :: IO ()
-main = thermoprintServer def
diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index 9b8d719..4018d17 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -1,8 +1,20 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE TypeOperators              #-}
 
 module Thermoprint.Server
        ( thermoprintServer
        , module Data.Default.Class
+       , module Servant.Server.Internal.Enter
        ) where
 
 import Data.Default.Class
@@ -11,42 +23,160 @@ import qualified Config.Dyre as Dyre
 import System.IO (hPutStrLn, stderr)
 import System.Exit (exitFailure)
 
-import Control.Monad ((<=<))
+import Control.Monad ((<=<), mapM_, liftM2)
+import Prelude hiding ((.), id)
+import Control.Category
+
+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 qualified Network.Wai.Handler.Warp as Warp
 import Network.Wai (Application)
 
+import Servant
 import Servant.Server
+import Servant.Server.Internal.Enter
 
-import Thermoprint.API
+import Database.Persist
+import Database.Persist.Sql
+import Database.Persist.TH
 
 data Config = Config { dyreError    :: Maybe String
                      , warpSettings :: Warp.Settings
                      }
 
 instance Default Config where
-  def = Config { dyreError = Nothing
+  def = Config { dyreError    = Nothing
                , warpSettings = Warp.defaultSettings
                }
 
-thermoprintServer :: Config -> IO ()
-thermoprintServer = Dyre.wrapMain $ Dyre.defaultParams
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+Job
+    content Printout
+Draft
+    content Printout
+|]
+
+
+thermoprintServer :: ( MonadLogger m
+                     , MonadIO m
+                     , MonadBaseControl IO m
+                     , MonadReader ConnectionPool m
+                     ) => (m :~> IO) -> Config -> IO ()
+thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams
   { Dyre.projectName = "thermoprint-server"
   , Dyre.realMain    = realMain <=< handleDyreErrors
   , 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
+        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
+
+(<||>) :: Monad m => m a -> m b -> m (a :<|> b)
+(<||>) = liftM2 (:<|>)
+infixr 9 <||>
+
+
+thermoprintServer' :: ( Monad m
+                      ) => ServerT ThermoprintAPI (EitherT ServantErr m)
+thermoprintServer' = listPrinters
+                     :<|> queueJob <||> printerStatus
+                     :<|> listJobs
+                     :<|> getJob <||> jobStatus <||> getJobPrinter <||> deleteJob
+                     :<|> (listDrafts :<|> addDraft)
+                     :<|> updateDraft <||> getDraft <||> deleteDraft
+
+
+listPrinters :: ( Monad m
+                ) => EitherT ServantErr m (Set PrinterId)
+listPrinters = return Set.empty
+
+queueJob :: ( Monad m
+            ) => PrinterId
+            -> Printout
+            -> EitherT ServantErr m API.JobId
+queueJob = return undefined
+
+printerStatus :: ( Monad m
+                 ) => PrinterId
+                 -> EitherT ServantErr m PrinterStatus
+printerStatus = return undefined
+
+listJobs :: ( Monad m
+            ) => Maybe PrinterId
+            -> Maybe API.JobId
+            -> Maybe API.JobId
+            -> EitherT ServantErr m (Seq API.JobId)
+listJobs = return undefined
+
+getJob :: ( Monad m
+          ) => API.JobId
+          -> EitherT ServantErr m Printout
+getJob = return undefined
+
+jobStatus :: ( Monad m
+             ) => API.JobId
+             -> EitherT ServantErr m 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 = return undefined
+
+listDrafts :: ( Monad m
+              ) => EitherT ServantErr m (Set API.DraftId)
+listDrafts = return undefined
+
+addDraft :: ( Monad m
+            ) => Printout
+            -> EitherT ServantErr m API.DraftId
+addDraft = return undefined
 
-handleDyreErrors :: Config -> IO Config
-handleDyreErrors cfg
-  | Just msg <- dyreError cfg = do
-      hPutStrLn stderr msg
-      exitFailure
-      return undefined
-  | otherwise = return cfg
-      
+updateDraft :: ( Monad m
+               ) => API.DraftId
+               -> Printout
+               -> EitherT ServantErr m ()
+updateDraft = return undefined
 
-realMain :: Config -> IO ()
-realMain cfg@(Config{..}) = Warp.runSettings warpSettings $ serve thermoprintAPI thermoprintServer' 
+getDraft :: ( Monad m
+            ) => API.DraftId
+            -> EitherT ServantErr m Printout
+getDraft = return undefined
 
-thermoprintServer :: Server ThermoprintAPI
-thermoprintServer = undefined
+deleteDraft :: ( Monad m
+               ) => API.DraftId
+               -> EitherT ServantErr m ()
+deleteDraft = return undefined