Nonfunctional API framework for server

5 files changed, 198 insertions, 32 deletions

diff --git a/server/default-conf/Main.hs b/server/default-conf/Main.hs
new file mode 100644
index 0000000..0aa7d91
--- /dev/null
+++ b/server/default-conf/Main.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import Thermoprint.Server
+
+import Control.Monad.Trans.Resource
+import Control.Monad.Logger
+import Control.Monad.Reader
+
+import Database.Persist.Sqlite
+
+main :: IO ()
+main = thermoprintServer (Nat runSqlite) def
+  where
+    runSqlite :: ReaderT ConnectionPool (LoggingT (ResourceT IO)) a -> IO a
+    runSqlite = runResourceT . runStderrLoggingT . withSqlitePool ":memory:" 1 . runReaderT
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
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index c8586ae..0aa1870 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -16,16 +16,35 @@ build-type:          Simple
 -- extra-source-files:  
 cabal-version:       >=1.10
 
-executable thermoprint-server
-  main-is:             Main.hs
+library
+  exposed-modules:     Thermoprint.Server
   -- other-modules:       
   -- other-extensions:    
-  build-depends:       base >=4.8 && <4.9
+  build-depends:       base >=4.8 && <5
                      , thermoprint-spec ==3.0.*
                      , dyre >=0.8.12 && <1
                      , data-default-class >=0.0.1 && <1
                      , wai >=3.0.4 && <4
                      , servant-server >=0.4.4 && <1
                      , warp >=3.1.9 && <4
+                     , persistent >=2.2 && <3
+                     , persistent-template >=2.1.4 && <3
+                     , transformers >=0.3.0 && <1
+                     , mtl >=2.2.1 && <3
+                     , resourcet >=1.1.7 && <2
+                     , monad-logger >=0.3.13 && <1
+                     , containers >=0.5.6 && <1
+                     , either >=4.4.1 && <5
   hs-source-dirs:      src
+  default-language:    Haskell2010
+
+executable thermoprint-server
+  main-is:             Main.hs
+  build-depends:       base >=4.8 && <5
+                     , thermoprint-server -any
+                     , persistent-sqlite >=2.2 && <3
+                     , mtl >=2.2.1 && <3
+                     , resourcet >=1.1.7 && <2
+                     , monad-logger >=0.3.13 && <1
+  hs-source-dirs:      default-conf
   default-language:    Haskell2010
\ No newline at end of file
diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix
index 7154dc3..c6a6224 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -1,15 +1,21 @@
-{ mkDerivation, base, data-default-class, dyre, servant-server
-, stdenv, thermoprint-spec, wai, warp
+{ mkDerivation, base, containers, data-default-class, dyre, either
+, monad-logger, mtl, persistent, persistent-sqlite
+, persistent-template, resourcet, servant-server, stdenv
+, thermoprint-spec, transformers, wai, warp
 }:
 mkDerivation {
   pname = "thermoprint-server";
   version = "0.0.0";
   src = ./.;
-  isLibrary = false;
+  isLibrary = true;
   isExecutable = true;
+  libraryHaskellDepends = [
+    base containers data-default-class dyre either monad-logger mtl
+    persistent persistent-template resourcet servant-server
+    thermoprint-spec transformers wai warp
+  ];
   executableHaskellDepends = [
-    base data-default-class dyre servant-server thermoprint-spec wai
-    warp
+    base monad-logger mtl persistent-sqlite resourcet
   ];
   homepage = "http://dirty-haskell.org/tags/thermoprint.html";
   description = "Server for thermoprint-spec";